Compter bordures d'une cellule VBA

Bonjour,

Dans une marco, j'ai besoin de vérifier avec le maximum d'efficacité si une cellule possède plus d'une bordure.

J'ai essayé borders.count, mais bon ça m'a donné le résultat décrit dans l'aide : le nombre d'objets de la collection, c'est à dire 6.

Je suis aussi passé par une boucle for, pour i allant de 5 à 12, pour vérifier les bordures 1 par 1. ça marche, mais c'est trop long, même avec des conditions de sortie de boucle for

Est-ce que vous n'auriez pas une petite idée ?

Merci d'avance,

Florian

PS : le but est de trouver un tableau dans une feuille excel, dont potentiellement toutes les cellules sont vides, et simplement mises en forme avec couleur et/ou bordures. il s'agit donc de vérifier certaines cellules, histoire de voir si elles sont mises en forme, sachant que les cellules à 1 bordure sont certainement des cellules au bord du tableau.

PS2 : voila pour le contexte, mais focus sur la question des bordures merci !

Bonsoir,

Likesmetal a écrit :

Je suis aussi passé par une boucle for, pour i allant de 5 à 12, pour vérifier les bordures 1 par 1. ça marche, mais c'est trop long, même avec des conditions de sortie de boucle for

Avec une fonction...

Function BordersCount(Rg As Range) As Byte
Dim i, j As Byte
  For i = 1 To 12
    j = IIf(Rg.Borders(i).LineStyle <> xlNone, j + 1, j)
  Next
BordersCount = j
End Function

... je ne trouve pas ça trop long.

Peut-être qu"un fichier pourrait nous permettre de mieux aborder votre problématique...

Cdt,

Darzou

Bonjour,

Merci pour votre réponse,

cependant, j'ai déjà mis en oeuvre cette solution, et elle consomme trop de temps.

Le but est d'insérer un tableau dans word avec un copier/collé, réalisé par la macro.

Je parcours au moins 207 cellules, et cela demande bien 10s, avec une boucle for bien optimisée, allant de 5 à 12.

Voici le code :

fonction d'insertion du tableau dans word :

Option Explicit
Dim xlWB As Excel.Workbook
Dim xlApp As Excel.Application

Sub Copie_tableau(Chemin As String)

Dim fin As Boolean
Dim FirstLi As Integer
Dim FirstCol As Integer
Dim LastLi As Integer
Dim LastCol As Integer
Dim doc As Worksheet
Dim i As Integer, j As Integer

Set xlApp = CreateObject("Excel.Application")
Set xlWB = xlApp.Workbooks.Open(Chemin)

Set doc = xlWB.Worksheets(1)

fin = False

FirstLi = 1
FirstCol = 1

xlApp.DisplayAlerts = False

With doc

LastLi = .Cells.SpecialCells(xlCellTypeLastCell).Row
LastCol = .Cells.SpecialCells(xlCellTypeLastCell).Column

If LastLi = 1 And LastCol = 1 Then
    MsgBox ("Feuille excel vide")
    Exit Sub
End If

'recherche auto de la première colonne
i = 0
    While fin = False
        If .Cells.Columns(FirstCol).SpecialCells(xlCellTypeLastCell).Row = 1 Then
            FirstCol = FirstCol + 1
        Else
            fin = True
        End If
    Wend

    fin = False

'recherche auto de la première ligne
    While fin = False
        If .Cells.Rows(FirstLi).SpecialCells(xlCellTypeLastCell).Column = 1 Then
            FirstLi = FirstLi + 1
        Else
            fin = True
        End If
    Wend

'vérif excel non vide
    If LastLi = FirstLi And LastCol = FirstCol Then
        MsgBox ("Feuille excel vide")
        Exit Sub
    End If

'recherche manuelle de la première ligne

    fin = False
    j = 0
    While fin = False

        If Valeur(FirstLi, FirstCol + j) <> "" Then
            fin = True
        ElseIf j < FirstCol - LastCol Then
            j = j + 1
        Else
            FirstLi = FirstLi + 1
            j = 0
        End If

    Wend

'recherche manuelle de la première colonne
    fin = False

    j = 0
    While fin = False
        If Valeur(FirstLi + j, FirstCol) <> "" Then
            fin = True
        ElseIf j < FirstLi - LastLi Then
            j = j + 1
        Else
            FirstCol = FirstCol + 1
            j = 0
        End If
    Wend

    j = 0
    fin = False

'recherche manuelle de la dernière ligne
    While fin = False
            If Valeur(LastLi, FirstCol + j) = "" Then
                j = j + 1
                If j = LastCol - FirstCol Then
                    LastLi = LastLi - 1
                    j = 0
                End If
            Else
                fin = True
            End If
    Wend

'recherche manuelle de la dernière colonne
    fin = False
    i = .Cells.Columns(LastCol).SpecialCells(xlCellTypeLastCell).Row
    j = 0
    While fin = False
        If Valeur(i - j, LastCol) <> "" Then
            fin = True
        ElseIf j + 1 < i Then
            j = j + 1
        Else
            LastCol = LastCol - 1
            j = 0
            i = .Cells.Columns(LastCol).SpecialCells(xlCellTypeLastCell).Row
        End If
    Wend

    fin = False
    .Range(.Cells(FirstLi, FirstCol), .Cells(LastLi, LastCol)).Copy

End With
End Sub

Et la fonction Valeur qui nous intéresse ici :

Function Valeur(Li As Integer, Col As Integer) As Variant

Dim doc As Worksheet
Dim l As Integer
Dim k As Integer

Set doc = xlWB.Worksheets(1)
Valeur = ""
With doc
    k = 0
    With .Cells(Li, Col)
    For l = 5 To 12

        If .Cells(Li, Col).Borders(l).LineStyle <> xlLineStyleNone Then
                k = k + 1
        End If

        If k > 1 Then
        Valeur = k
        GoTo fin
        End If
    Next l
        If .Interior.ColorIndex <> xlColorIndexNone Or .Value <> "" Or .Borders.Count > 2 Then
            Valeur = 2
            GoTo fin
        End If
    End With
End With
fin:

End Function

C'est principalement la fonction valeur qui me pose problème :

Sur un petit tableau de 23 lignes et 14 colonnes, il me faut 2-3s pour initialiser la fonction (démarrage d'excel en gros), puis 10-15s pour détecter la dernière colonne. La détection automatique détecte 9 colonnes de trop, soit 207 appels de la fonction Valeur environ.

Pour 207 appels, je trouve que 10-15s c'est trop long.

Edit : J'ai trouvé ce qui prend du temps : ce n'est pas la boucle For, c'est la commande

set doc = xlWB.Worksheet(1)

Merci Darzou, c'est donc bon avec la boucle for.