Discussion :

[totorcalais]

Bonjour,

Je suis confronté depuis quelques jours à un problème dont il me manque sûrement la clé.

Tout d'abord, j'explique ce que je recherche :

Je possède une feuille qui contient des cellules colorisées selon un code de couleur précis définissant un ordre de préférence (ex : rouge =1, orange =2...).
Ces cellules contiennent un texte.
Chaque ligne est indépendante et correspond à un item (et chacune contient donc 5 cases colorisées avec un texte mais disposées de façon aléatoire).

Mon objectif est de lire le champ de cellule de chaque ligne et, selon la couleur, les copier et le coller dans une autre feuille où j'ai 5 cases qui attendent pour la première, le contenu de la cellule détectée en rouge, en 2, le contenu de la cellule détectée en orange, etc...

Cela pour chaque ligne.

Pour la partie détection couleur et copie vers une autre feuille (pour une ligne), cela fonctionne sans problème.

Mais pour une seule ligne.

Mon objectif est de faire une boucle qui incrémenterait le range (ligne par ligne) avec la même procédure. Pour cela, je pensais que l'offset serait idéal. MAis rien ne se passe comme prévu et je me retrouve coincé avec la sélection des feuilles (mon programme semble perdu et je ne sais pas où il cherche ni ce qu'il trouve).

Voici ma boucle basique de détection couleur et copie dans une cellule qui fonctionne bien (module).

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
Sub Macro1()
    Dim Ws As Worksheet
    Dim C As Range
    
   

    Dim PlageACalculer As Range
    Dim CelluleCouleurReference As Range
    Dim dest As Range

  
    For Each Ws In ThisWorkbook.Worksheets
    If Ws.Name = "Liste-officielle" Then GoTo sortie
    If Ws.Name = "recap3B" Then GoTo sortie
    If Ws.Name = "3eB" Then
    

    Set PlageACalculer = Range("3eB!f3:s3")
    Set dest = Range("recap3B!F3")
   
    Set CelluleCouleurReference = Range("3eB!C32") 'là ou se trouve ma couleur rouge
     
    For Each C In PlageACalculer
    
        If (C.Interior.ColorIndex = CelluleCouleurReference.Interior.ColorIndex) Then

       dest.Value = C.Value
        
        End If
     Next C
   
'---Emplacement du code suivant qui ne fonctionne pas (voir ci après). 
'PRECISION : J'ai laissé la première itération car je voulais contrôler que cela fonctionnait avant de tout faire disparaître par une routine commune à toutes les lignes d'un coup
'---FIN ZONE Emplacement du code suivant qui ne fonctionne pas . 

     End If
sortie:
     Next Ws
End Sub

Je me retrouve bien avec le texte de ma cellule rouge pour la ligne de la plageacalculer.
Mais incrémenter, cela ne marche plus...
Voici mon code offset qui ne fonctionne pas:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
 
     Set PlageACalculer = Range("f3:s3") ' j avais essayé avec référence de la feuille mais cela bloquait l offset alors j'ai essayé avec un with, sans succès...
     Set dest = Range("F3")
     For i = 1 To 28
 
 
    'With Sheets("3eB")
    PlageACalculer.Offset(i, 0).Select
    'End With
 
    'With Sheets("recap3B")
    dest.Offset(i, 0).Select
    'End With
 
    Set CelluleCouleurReference = Range("3eB!C32")
 
    For Each C In PlageACalculer
 
        If (C.Interior.ColorIndex = CelluleCouleurReference.Interior.ColorIndex) Then
 
       'MsgBox (C)
       dest.Sheets("recap3B").Value = C.Sheets("3eB").Value ' j ai essayé d'if=dentifier la feuille avec un sheets, mais rien n'y fait...
 
        End If
     Next C
     Next i

Quelqu'un pourrait il m'aider?
Où vais je devoir me résigner à copier ces cellules détectées dans une autre zone d'une même feuille pour ensuite le copier/coller en une fois?

Très cordialement,

Totor

[Invité]

Bonjour,

Une solution possible avec ce code dans le fichier joint :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
 
Sub RecupererLesInfosEnFonctionDesCouleurs()
 
Dim ShSource As Worksheet
Dim ColonneSource As Long
Dim PlageSource As Range
Dim CelluleSource As Range
 
 
Dim ShCible As Worksheet
Dim LigneTitreCible As Long
Dim LigneEnCoursCible As Long
Dim ColonneCible As Long
Dim CouleursCible As Range
Dim CelluleCouleur As Range
 
 
    ' Définition de l'onglet Recap et des couleurs de référence
    Set ShCible = Worksheets("recap3B")
    With ShCible
         LigneTitreCible = 2
         LigneEnCoursCible = LigneTitreCible + 1
         Set CouleursCible = .Range(.Cells(LigneTitreCible, 6), .Cells(LigneTitreCible, 10))
         .Range(CouleursCible.Offset(1, 0), CouleursCible.Offset(29, 0)).Clear ' Effacement des résultats précédents
    End With
 
    ' Définition de l'onglet source et de la plage de données
    Set ShSource = Worksheets("3eB")
    Set PlageSource = ShSource.Range("F3:F30")
 
    For Each CelluleSource In PlageSource
        For ColonneSource = 0 To 13   ' De la colonne F à la colonne S
            For Each CelluleCouleur In CouleursCible
                If CelluleSource.Offset(0, ColonneSource).Interior.Color = CelluleCouleur.Interior.Color Then
                   ShCible.Cells(LigneEnCoursCible, CelluleCouleur.Column) = CelluleSource.Offset(0, ColonneSource)
                   Exit For
                End If
            Next CelluleCouleur
        Next ColonneSource
        LigneEnCoursCible = LigneEnCoursCible + 1
    Next CelluleSource
 
    Set PlageSource = Nothing
    Set ShSource = Nothing
    Set CouleursCible = Nothing
    Set ShCible = Nothing
 
End Sub

Pièce jointe 175745

Cordialement.

[totorcalais]

Merci, c'est tout à fait cela que je cherchais.

J'ai testé ta version et cela fonctionne nickel.

Il ne me reste plus qu'à transposer après avoir décodé ta proposition.

Je savais qu'en postant ici j'aurai des idées de réponse mais là, je suis estomaqué par la qualité de la réponse et le fait que tu aies pris le temps de faire un exemple.



PS : j'ai transposé et cela fonctionne nickel. Encore merci!