Aide code entre deux feuilles

Le 16/01/2022 à 11:37

Bonjour,

J'essaie de me crée un compteur de couleur. J'aimerai les résultats sur une feuille et la recherche sur une autre. Je bloque bêtement

5comptage-couleur.xlsm (21.06 Ko)
Le 16/01/2022 à 12:06

Bonjour Juju, bonjour le forum,

Essaie comme ça :

Sub Macro1()
Dim C As Worksheet 'déclare la variable C (onglet des Couleurs)
Dim R As Worksheet 'déclare la variable R (onglet des Résultats)
Dim PL As Range 'déclare la variable PL (PLage)
Dim CEL As Range 'déclare la variable CEL (CELlule)
Dim I As Byte 'déclare la variable I (Incrément)
Dim TC(1 To 4) As Variant 'déclare le tableau de 4 variables TC (Tableau des Couleurs)
Dim CC(1 To 4) As Integer 'déclare le tableau de 4 variables CC (Compteur des Couleurs)

Set C = Worksheets("Feuil2") 'définit l'onglet C
Set R = Worksheets("Feuil1") 'définit l'onglet R
Set PL = C.Range("A5").CurrentRegion 'définit la plage PL
Set PL = PL.Offset(1, 0).Resize(PL.Rows.Count - 1) 'redéfinit PL sans la première ligne
For I = 1 To 4 'boucle sur 4 lignes
    TC(I) = R.Cells(I, "C").Interior.Color 'définit la couleur TC(I)
Next I 'prochaine ligne
For Each CEL In PL.Rows 'boucle 1 : sur toutes les cellules CEL des lignes de la plage PL
    For I = 1 To 4 'boucle 2 : sur les 4 couleurs
        'si la couleur de la cellule CEL est égale à la couleur TC(I), incrémente le compteur CC(I), sort de la boucle 2
        If CEL.Interior.Color = TC(I) Then CC(I) = CC(I) + 1: Exit For
    Next I 'prochaine couleur de la boucle 2
Next CEL 'prochaine cellule de la boucle 1
R.Range("D1").Resize(4, 1) = Application.Transpose(CC) 'renvoie dans D1 redimensionnées le tableau CC transposé
End Sub
Le 16/01/2022 à 12:51

Bonjour

Si on est allergique aux tableaux structurés on peut s'en passer mais pourquoi se compliquer la vie?

2comptage-couleur.xlsm (22.36 Ko)

Sans rien changer au fichier originel

Sub compteCouleurs()
  Dim cel1 As Range, cel2 As Range
  Dim rng1 As Range, rng2 As Range
  Set rng1 = Sheets("Feuil2").Range("A5").CurrentRegion.Columns(1)
  Set rng2 = Sheets("Feuil1").Range("C1:C4")
  ' Remise à 0 du tableau
  For Each cel2 In rng2.Cells
     cel2.Offset(0, 1) = 0
  Next cel2

  ' Comptage des lignes
  For Each cel1 In rng1.Cells
    For Each cel2 In rng2.Cells
      If cel1.Interior.Color = cel2.Interior.Color Then cel2.Offset(0, 1) = cel2.Offset(0, 1) + 1
    Next cel2
  Next cel1

End Sub
Le 16/01/2022 à 13:02

Bonjour le fil, bonjour le forum,

Si on est allergique aux tableaux structurés on peut s'en passer mais pourquoi se compliquer la vie?

C'est un peu ça... Trouver la première cellule vide d'une colonne d'un tableau structuré qui n'a pas toutes les lignes remplies, ça me gave grave...

Le 16/01/2022 à 13:29

Bonjour ThauThème

Trouver la première cellule vide d'une colonne d'un tableau structuré qui n'a pas toutes les lignes remplies, ça me gave grave...

Tu peux m'expliquer parce que perso je ne vois pas le problème.

Rechercher des sujets similaires à "aide code entre deux feuilles"