Récupérer la zone encadrée de bordure (vba excel)
Résolu
_aqw_
-
eriiic Messages postés 25847 Date d'inscription Statut Contributeur Dernière intervention -
eriiic Messages postés 25847 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
A voir également:
- Récupérer la zone encadrée de bordure (vba excel)
- Alternative zone telechargement - Accueil - Outils
- Liste déroulante excel - Guide
- Recuperer message whatsapp supprimé - Guide
- Word et excel gratuit - Guide
- Comment calculer la moyenne sur excel - Guide
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
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.
_aqw_
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
ho et si un modérateur peut mettre en résolu ? j'aurais du m'inscrire, je peu pas modifier
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
