Récupérer la zone encadrée de bordure (vba excel)
Résolu
_aqw_
-
eriiic Messages postés 24581 Date d'inscription Statut Contributeur Dernière intervention -
eriiic Messages postés 24581 Date d'inscription Statut Contributeur Dernière intervention -
Bonjour,
Je cherche un moyen fiable de récupérer les adresses de chaque cellules comprise dans une zone fermée délimitée par des bordure épaisses. Cette zone n'est pas forcément rectangulaire et peut contenir des trous de plusieurs cellules eux mêmes délimités par des bordures. Ces adresses seraient alors concaténés afin par exemple de définir un nom pour la zone quelles composent.
Merci de vos réponses
Je cherche un moyen fiable de récupérer les adresses de chaque cellules comprise dans une zone fermée délimitée par des bordure épaisses. Cette zone n'est pas forcément rectangulaire et peut contenir des trous de plusieurs cellules eux mêmes délimités par des bordures. Ces adresses seraient alors concaténés afin par exemple de définir un nom pour la zone quelles composent.
Merci de vos réponses
2 réponses
-
Bonjour,
Si ça peut avoir n'importe quelle forme ça serait un code assez long à faire et complexe, sûrement récursif ou tout au moins avec une arborescence à gérer.
A mon avis tu auras plus vite de le faire à la main que d'attendre que qq'un ait le temps et ose se lancer.
eric
En essayant continuellement, on finit par réussir.
Donc plus ça rate, plus on a de chances que ça marche.(les Shadoks)
En plus du merci (si si, ça se fait !!!), penser à mettre en résolu. Merci -
Merci de ton implication eriiic. Je pensais aussi à du récursif dans un premier temps.
Finalement je me suis "bidouillé" cette macro qui n'est peut être pas la plus optimisé mais qui fera le travail en testant les bordures gauches et supérieurs ainsi que les cellules adjacentes. Techniquement un seul test aurait suffit mais la j'en fait deux pour vérifier que la zone est bien fermée.
Je la poste ici au cas où cela intéresserais quelqu'un.
Sub TabSelect() Dim a As Boolean, b As Boolean Dim d As Range For Each c In ActiveSheet.UsedRange If c.Borders(xlEdgeLeft).LineStyle = xlContinuous Then If d Is Nothing Then a = True ElseIf Intersect(d, c.Offset(0, -1)) Is Nothing Then a = True End If Else If Not d Is Nothing Then If Not Intersect(d, c.Offset(0, -1)) Is Nothing Then a = True End If If c.Borders(xlEdgeTop).LineStyle = xlContinuous Then If d Is Nothing Then b = True ElseIf Intersect(d, c.Offset(-1, 0)) Is Nothing Then b = True End If Else If Not d Is Nothing Then If Not Intersect(d, c.Offset(-1, 0)) Is Nothing Then b = True End If If a And b Then If d Is Nothing Then Set d = c Else: Set d = Union(d, c) End If ElseIf Not a And Not b Then Else: MsgBox "incohérence détéctée pour la cellule " & c.Address Exit Sub End If a = False b = False Next ActiveWorkbook.Names.Add Name:="namedfield", RefersTo:="=" & d.Address End Sub
_aqw_-
Petite mise à jour de mon code sinon les tableaux situés trop proche des bords de la feuille entrainent une erreur dus à l'utilisation de la fonction Offset
Sub TabSelect() Dim a As Boolean, b As Boolean Dim d As Range, c As Range For Each c In ActiveSheet.UsedRange If c.Borders(xlEdgeLeft).LineStyle = xlContinuous Then If d Is Nothing Or c.Column = 1 Then a = True ElseIf Intersect(d, c.Offset(0, -1)) Is Nothing Then a = True End If Else If Not d Is Nothing And c.Column <> 1 Then If Not Intersect(d, c.Offset(0, -1)) Is Nothing Then a = True End If If c.Borders(xlEdgeTop).LineStyle = xlContinuous Then If d Is Nothing Or c.Row = 1 Then b = True ElseIf Intersect(d, c.Offset(-1, 0)) Is Nothing Then b = True End If Else If Not d Is Nothing And c.Row <> 1 Then If Not Intersect(d, c.Offset(-1, 0)) Is Nothing Then b = True End If If a And b Then If d Is Nothing Then Set d = c Else: Set d = Union(d, c) End If ElseIf Not a And Not b Then Else: MsgBox "incohérence détéctée pour la cellule " & c.Address Exit Sub End If a = False b = False Next ActiveWorkbook.Names.Add Name:="namedfield", RefersTo:="=" & d.Address End Sub
ho et si un modérateur peut mettre en résolu ? j'aurais du m'inscrire, je peu pas modifier -
Bonjour,
Je dis chapeau :-)
Je n'appellerais pas ça de la bidouille, c'est bien pensé je trouve.
J'ai essayé de le torturer, aucune anomalie trouvée tant qu'on a des courbes entièrement fermées.
En aussi peu de lignes, je m'attendais à pire. Bravo et merci pour eux :-)
Je met en résolu.
eric
-
