Sujet Précédent Sujet Suivant

Récupérer la zone encadrée de bordure (vba excel)

Résolu/Fermé
_aqw_ - Modifié par _aqw_ le 8/07/2015 à 17:59
eriiic Messages postés 24569 Date d'inscription mardi 11 septembre 2007 Statut Contributeur Dernière intervention 28 décembre 2023 - 16 juil. 2015 à 18:20
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

A voir également:

2 réponses

Réponse 1 / 2
eriiic Messages postés 24569 Date d'inscription mardi 11 septembre 2007 Statut Contributeur Dernière intervention 28 décembre 2023 7 209
Modifié par eriiic le 8/07/2015 à 18:26
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
0
Réponse 2 / 2
_aqw_
Modifié par _aqw_ le 16/07/2015 à 11:39
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_
0
_aqw_
Modifié par _aqw_ le 16/07/2015 à 13:22
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
0
eriiic Messages postés 24569 Date d'inscription mardi 11 septembre 2007 Statut Contributeur Dernière intervention 28 décembre 2023 7 209
16 juil. 2015 à 18:20
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
0