Excel - VBA - Reconnaissance d'une céllule

Question

Bonjour, 

Avec mon faible niveau de programmation je m'efforce de créer un programme qui compte les différentes cellules de couleurs dans un tableau et qui compte les cellules qui sont encadrées en bordure épaisse.

Par exemple :
cellule A1 rouge - je dois obtenir 1 dans la cellule B1
celle A2 encadrée - je dois obtenir 1 dans la cellule B2
celle A3 encadrée et rouge - je dois obtenir obtenir +1 dans B1 et +1 dans la cellule B2

Voici un début de programme qui fonctionne pour le comptage des couleurs :

Sub cptcouleur()

Dim cpt As Long
Dim cpt1 As Long
Dim cpt2 As Long



cpt = 0
cpt1 = 0
For i = 1 To 60
For j = 1 To 60
If Cells(i, j).Interior.ColorIndex = 3 Then
cpt = cpt + 1
ElseIf Cells(i, j).Interior.ColorIndex = 6 Then
cpt1 = cpt1 + 1


End If

Next j
Next i
Range("A1").Value = cpt
Range("B1").Value = cpt1

End Sub

Il suffit que mette en place plusieurs compteur pour toutes les couleurs à compter.

Par contre pour les cellules encadrées, j'ai enregistré une macro.

Voici la macro
Sub Macro3()
'
' Macro3 Macro
'

'
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
End Sub

Je n'arrive pas l'intégrer dans un boucle pour faire compter les bordures et donc lui faire reconnaitre une cellule.

Merci de m'aider si vous avez une solution.EXCE



Configuration: Windows XP / Firefox 3.6.13

Info · Answer

Bonjour,

Peut-être comme ceci : ???


Option Explicit

Sub CompteCellules()

    Dim Cpt As Long, I As Long, J As Long
        Dim Flag As Boolean

    Application.ScreenUpdating = False

    Flag = False
    Cpt = 0
    For I = 1 To 60
        For J = 1 To 60
            Cells(I, J).Select
            With Selection
                If (.Borders(xlEdgeLeft).LineStyle = xlContinuous) Then
                    Flag = True
                Else
                    Flag = False
                End If
                If (.Borders(xlEdgeTop).LineStyle = xlContinuous And Flag) Then
                    Flag = True
                Else
                    Flag = False
                End If
                If (.Borders(xlEdgeBottom).LineStyle = xlContinuous And Flag) Then
                    Flag = True
                Else
                    Flag = False
                End If
                If (.Borders(xlEdgeRight).LineStyle = xlContinuous And Flag) Then
                    Flag = True
                Else
                    Flag = False
                End If
                
                If (Flag) Then
                    Cpt = (Cpt + 1)
                End If
            End With
        Next J
    Next I

    Application.ScreenUpdating = True
    MsgBox CStr(Cpt)

End Sub
'


Info

lermite222 · Answer

Bonjour,
Remarques,
tu commence à la ligne 1 mais tu met les résultats dans cette même ligne ??
Tu veux compter sur 60 colonnes ??

Sub Compter() 
Dim Lig As Long, Col As Integer 
    For Lig = 2 To 60 
        For Col = 1 To 60 
            If Cells(Lig, Col).Interior.ColorIndex <> xlNone Then [A1] = [A1] + 1 
            If Cells(Lig, Col).Borders(xlEdgeLeft).LineStyle <> xlNone Then [B1] = [B1] + 1 
        Next Col 
    Next Lig 
End Sub

A+
L'expérience instruit plus sûrement que le conseil. (André Gide)
Si tu te cognes à un pot et que ça sonne creux, c'est pas forcément le pot qui est vide. ;-)(Confucius)
NOTE : Je ne répond pas aux MP pour les questions techniques.
Ça doit se passer sur le forum pour que tous puisse y participer ou en profiter.

gerald13500 · Answer

Bonjour,  

je viens d'utiliser votre méthode. 
Elle marche bien. 

Mais maintenant, je souhiate qu'Excel fasse la différence entre une cellule encadrée (xlmedium) en noir et un cellule encardrée en Rouge (Xl medium). 

Voici mon code, PB Excel ne fait pas la différence (où est mon erreur). 

Sub CompteurCouleurs_CompteurBordures() 

'********** DECLARATION DES VARAIBLES **********. 

Dim Cpt9 As Long 
Dim Cpt10 As Long 

Dim Feedback1 As Boolean 
Dim Feedback2 As Boolean 
Dim I As Long 
Dim J As Long 


'********** INITIALISATION DES VARIABLES **********. 

Cpt9 = 0 
Cpt10 = 0 


Feedback1 = False 
Feedback2 = False 



For I = 1 To 30 
    For J = 1 To 30 

     
        Cells(I, J).Select 
         
        With Selection 

'********** CELLULE ENCADREE NOIRE **********. 
 If (.Borders(xlEdgeTop).LineStyle = xlContinuous And (.Borders(xlEdgeTop).Weight = xlMedium)) Then 
        Feedback1 = True 
        Else 
        Feedback1 = False 
        End If 

  If (.Borders(xlEdgeRight).LineStyle = xlContinuous And Feedback1 And (.Borders(xlEdgeRight).Weight = xlMedium)) Then 
        Feedback1 = True 
        Else 
        Feedback1 = False 
        End If 

  If (.Borders(xlEdgeBottom).LineStyle = xlContinuous And Feedback1 And (.Borders(xlEdgeBottom).Weight = xlMedium)) Then 
        Feedback1 = True 
        Else 
        Feedback1 = False 
        End If 
         
 If (.Borders(xlEdgeLeft).LineStyle = xlContinuous And Feedback1 And (.Borders(xlEdgeLeft).Weight = xlMedium)) Then 
        Feedback1 = True 
        Else 
        Feedback1 = False 
        End If 
         
        If (Feedback1) Then 
        Cpt9 = Cpt9 + 1 
        End If 
'********** CELLULE ENCADREE ROUGE **********. 
        If (.Borders(xlEdgeTop).LineStyle = xlContinuous And (.Borders(xlEdgeTop).Weight = xlMedium) And (.Borders(xlEdgeTop).Color = 255)) Then 
        Feedback2 = True 
        Else 
        Feedback2 = False 
        End If 
         
        If (.Borders(xlEdgeRight).LineStyle = xlContinuous And (.Borders(xlEdgeRight).Weight = xlMedium) And Feedback2 And (.Borders(xlEdgeRight).Color = 255)) Then 
        Feedback2 = True 
        Else 
        Feedback2 = False 
        End If 
         
        If (.Borders(xlEdgeBottom).LineStyle = xlContinuous And (.Borders(xlEdgeBottom).Weight = xlMedium) And Feedback2 And (.Borders(xlEdgeBottom).Color = 255)) Then 
        Feedback2 = True 
        Else 
        Feedback2 = False 
        End If 
         
        If (.Borders(xlEdgeLeft).LineStyle = xlContinuous And (.Borders(xlEdgeLeft).Weight = xlMedium) And Feedback2 And (.Borders(xlEdgeLeft).Color = 255)) Then 
        Feedback2 = True 
        Else 
        Feedback2 = False 
        End If 
         
        If (Feedback2) Then 
        Cpt10 = Cpt10 + 1 
        End If 

end with 

Next J
       Next I

End sub

lermite222 · Answer

Hummmm, bien long tout ça, que pense tu de mon poste ?

Excel - VBA - Reconnaissance d'une céllule

4 réponses

Discussions similaires

Newsletters