[excel et VB] comptage de couleurs
Bonjour,
Ma question est surement simple mais elle dépasse mes faibles compétences techniques, même si quelques brides de réponses existent déjà sur le forum.
Je cherche dans un tableau complexe (pas forcément que des cellules adjacentes) à compter le nombre de cellules de chaque couleur (presque toutes les couleurs XL sont utilisées) et ensuite d'écrire le résultat pour chaque couleur dans une case particulière.
Si cette opération pouvait se faire automatiquement au fur et à mesure que je remplis le tableau, ce serait plus simple que de lancer une macro à chaque modification.
De plus, il y a plusieurs feuilles dans mon classeur, et j'ai besoin d'avoir un total par page et un général.
Merci à qui pourrait m'aider
Olivier
Ma question est surement simple mais elle dépasse mes faibles compétences techniques, même si quelques brides de réponses existent déjà sur le forum.
Je cherche dans un tableau complexe (pas forcément que des cellules adjacentes) à compter le nombre de cellules de chaque couleur (presque toutes les couleurs XL sont utilisées) et ensuite d'écrire le résultat pour chaque couleur dans une case particulière.
Si cette opération pouvait se faire automatiquement au fur et à mesure que je remplis le tableau, ce serait plus simple que de lancer une macro à chaque modification.
De plus, il y a plusieurs feuilles dans mon classeur, et j'ai besoin d'avoir un total par page et un général.
Merci à qui pourrait m'aider
Olivier
4 réponses
-
J'avais conçu un bout de macro pour le boulot pour faire du comptage de couleur dans un fichier excel.
Je vais le rechercher et voir ça ! -
Voilà en gros à quoi ressemble le macro, pour des couleurs simple, après il me smble qu'il fallait utiliser d'autres codes de couleurs pour les couleurs complexes.
Je vais regarder au boulot, car je n'ai pas chez moi la fin du macro que j'avais fait..là c'était juste un test...
Je regarde ça.
Mais avec ça, ça peut déjà permettre de faire des trucs..
Sub Bouton1_QuandClic()
'
sommeRouge = 0
compterRouge = 0
For Each cell In ActiveSheet.UsedRange
If cell.Interior.Color = vbBlack Then
On Error Resume Next
sommeRouge = sommeRouge + cell.Value
On Error GoTo 0
compterRouge = compterRouge + 1
End If
Next
If compterRouge = 1 Then c = "cellule" Else c = "cellules"
Range("c17").Select
ActiveCell.FormulaR1C1 = compterRouge & " "
sommeRouge = 0
compterRouge = 0
For Each cell In ActiveSheet.UsedRange
If cell.Interior.Color = vbRed Then
On Error Resume Next
sommeRouge = sommeRouge + cell.Value
On Error GoTo 0
compterRouge = compterRouge + 1
End If
Next
If compterRouge = 1 Then c = "cellule" Else c = "cellules"
Range("c18").Select
ActiveCell.FormulaR1C1 = compterRouge & " "
sommeRouge = 0
compterRouge = 0
For Each cell In ActiveSheet.UsedRange
If cell.Interior.Color = vbYellow Then
On Error Resume Next
sommeRouge = sommeRouge + cell.Value
On Error GoTo 0
compterRouge = compterRouge + 1
End If
Next
If compterRouge = 1 Then c = "cellule" Else c = "cellules"
Range("c19").Select
ActiveCell.FormulaR1C1 = compterRouge & " "
End Sub -
Voici une partie du macro final que j'avais concu...Pour un calcul de couleurs par ligne....
Si besoin de + de renseignements, le demander...
Sub centrage()
'
'
sommejaune = 0
compterjaune = 0
For Each cell In ActiveSheet.Range("A4:AO4")
If cell.Interior.ColorIndex = 3 Then
On Error Resume Next
sommejaune = sommejaune + cell.Value
On Error GoTo 0
compterjaune = compterjaune + 1
End If
Next
If compterjaune = 1 Then c = "cellule" Else c = "cellules"
Range("AT4").Select
ActiveCell.FormulaR1C1 = compterjaune & " "
'j 2L
sommejaune = 0
compterjaune = 0
For Each cell In ActiveSheet.Range("A5:AO5")
If cell.Interior.ColorIndex = 3 Then
On Error Resume Next
sommejaune = sommejaune + cell.Value
On Error GoTo 0
compterjaune = compterjaune + 1
End If
Next
If compterjaune = 1 Then c = "cellule" Else c = "cellules"
Range("AT5").Select
ActiveCell.FormulaR1C1 = compterjaune & " "
'j3l
sommejaune = 0
compterjaune = 0
For Each cell In ActiveSheet.Range("A6:AO6")
If cell.Interior.ColorIndex = 3 Then
On Error Resume Next
sommejaune = sommejaune + cell.Value
On Error GoTo 0
compterjaune = compterjaune + 1
End If
Next
If compterjaune = 1 Then c = "cellule" Else c = "cellules"
Range("AT6").Select
ActiveCell.FormulaR1C1 = compterjaune & " "
'j3l
sommejaune = 0
compterjaune = 0
For Each cell In ActiveSheet.Range("A7:AO7")
If cell.Interior.ColorIndex = 3 Then
On Error Resume Next
sommejaune = sommejaune + cell.Value
On Error GoTo 0
compterjaune = compterjaune + 1
End If
Next
If compterjaune = 1 Then c = "cellule" Else c = "cellules"
Range("AT7").Select
ActiveCell.FormulaR1C1 = compterjaune & " "
'j4l
sommejaune = 0
compterjaune = 0
For Each cell In ActiveSheet.Range("A8:AO8")
If cell.Interior.ColorIndex = 3 Then
On Error Resume Next
sommejaune = sommejaune + cell.Value
On Error GoTo 0
compterjaune = compterjaune + 1
End If
Next
If compterjaune = 1 Then c = "cellule" Else c = "cellules"
Range("AT8").Select
ActiveCell.FormulaR1C1 = compterjaune & " "
'j5l
sommejaune = 0
compterjaune = 0
For Each cell In ActiveSheet.Range("A9:AO9")
If cell.Interior.ColorIndex = 3 Then
On Error Resume Next
sommejaune = sommejaune + cell.Value
On Error GoTo 0
compterjaune = compterjaune + 1
End If
Next
If compterjaune = 1 Then c = "cellule" Else c = "cellules"
Range("AT9").Select
ActiveCell.FormulaR1C1 = compterjaune & " "
'j6l
sommejaune = 0
compterjaune = 0
For Each cell In ActiveSheet.Range("A10:AO10")
If cell.Interior.ColorIndex = 3 Then
On Error Resume Next
sommejaune = sommejaune + cell.Value
On Error GoTo 0
compterjaune = compterjaune + 1
End If
Next
If compterjaune = 1 Then c = "cellule" Else c = "cellules"
Range("AT10").Select
ActiveCell.FormulaR1C1 = compterjaune & " "
'j7l
sommejaune = 0
compterjaune = 0
For Each cell In ActiveSheet.Range("A11:AO11")
If cell.Interior.ColorIndex = 3 Then
On Error Resume Next
sommejaune = sommejaune + cell.Value
On Error GoTo 0
compterjaune = compterjaune + 1
End If
Next
If compterjaune = 1 Then c = "cellule" Else c = "cellules"
Range("AT11").Select
ActiveCell.FormulaR1C1 = compterjaune & " "
'j8l
sommejaune = 0
compterjaune = 0
For Each cell In ActiveSheet.Range("A12:AO12")
If cell.Interior.ColorIndex = 3 Then
On Error Resume Next
sommejaune = sommejaune + cell.Value
On Error GoTo 0
compterjaune = compterjaune + 1
End If
Next
If compterjaune = 1 Then c = "cellule" Else c = "cellules"
Range("AT12").Select
ActiveCell.FormulaR1C1 = compterjaune & " "
'j9l
sommejaune = 0
compterjaune = 0
For Each cell In ActiveSheet.Range("A13:AO13")
If cell.Interior.ColorIndex = 3 Then
On Error Resume Next
sommejaune = sommejaune + cell.Value
On Error GoTo 0
compterjaune = compterjaune + 1
End If
Next
If compterjaune = 1 Then c = "cellule" Else c = "cellules"
Range("AT13").Select
ActiveCell.FormulaR1C1 = compterjaune & " "
'j10l
sommejaune = 0
compterjaune = 0
For Each cell In ActiveSheet.Range("A14:AO14")
If cell.Interior.ColorIndex = 3 Then
On Error Resume Next
sommejaune = sommejaune + cell.Value
On Error GoTo 0
compterjaune = compterjaune + 1
End If
Next
If compterjaune = 1 Then c = "cellule" Else c = "cellules"
Range("AT14").Select
ActiveCell.FormulaR1C1 = compterjaune & " "
'j11l
sommejaune = 0
compterjaune = 0
For Each cell In ActiveSheet.Range("A15:AO15")
If cell.Interior.ColorIndex = 3 Then
On Error Resume Next
sommejaune = sommejaune + cell.Value
On Error GoTo 0
compterjaune = compterjaune + 1
End If
Next
If compterjaune = 1 Then c = "cellule" Else c = "cellules"
Range("AT15").Select
ActiveCell.FormulaR1C1 = compterjaune & " " -
salut
ça me plait bien la version pour la couleur rouge mais comment faire si on veut du noire et pour le calcule en ligne???,
