[excel et VB] comptage de couleurs

olivier -  
 coolmix -
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

4 réponses

  1.
    cb103 Messages postés 487 Statut Membre 69
     
    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 !
    0
  2. cb103 Messages postés 487 Statut Membre 69
     
    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
    0
  3. cb103 Messages postés 487 Statut Membre 69
     
    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 & " "
    0
  4. coolmix
     
    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???,
    0

Discussions similaires

Retrouver réglages couleurs d'origine de mon écran W10
LoulouSophie -
pistouri -

8 réponses