Copier cel couleur de Tab1 vers un autre onglet Col B

Reonjour le forum,

Je suis novice en vba et c’est la raison pour laquelle, j’aimerais votre aide pour réaliser une macro.

J’ai un fichier contenant 2 feuilles (Feuil4 et Feuil5).

Dans la Feuil4, il y a 1 tableau (TAB1) et dans la Feuil5, il y a 1 tableau (TAB2).

Je voudrais que la macro exécute des copier/coller des cellules à fond vert se trouvant dans (TAB1) de la Feuil4 vers (TAB2) de la Feuil5 (COLONNE B) en changeant la valeur des cellules par le chiffre « 1 ».

J’ai essayé de consulter les demandes similaires à la mienne mais hélas sans résultats 5 (c'est désolant).

Pouvez-vous dès lors jeter un coup d’œil à ma requête, s’il vous plait ?

La pièce jointe contient tous les détails, en espérant que vous comprendrez ce que je veux.

Merci d’avance.

ELAB

Bonjour ELAB

Essaie ceci sur une copie de ton classeur

Option Explicit
Sub test()
Dim r As Range, i As Long, j As Long, txt As String
Dim dico As Object
    Application.ScreenUpdating = False
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    With Sheets("Feuil4").Range("a8:iu18")
        For i = 2 To .Rows.Count
            For j = 2 To .Columns.Count
                If .Cells(i, j).Interior.ColorIndex = 4 Then
                    txt = .Cells(1, j).Value & .Cells(i, 1).Value
                    'dico.Item(txt) = Array(1, 4)
                     dico.Item(txt) = Empty
                End If
            Next
        Next
    End With
    With Sheets("Feuil5")
        With .Range("b8", .Range("b" & .Range("a" & .Rows.Count).End(xlUp).Row))
            .Interior.ColorIndex = xlNone
            .ClearContents
        End With
        For Each r In .Range("a8", .Range("a" & Rows.Count).End(xlUp))
            If dico.exists(r.Value) Then
                With r(, 2)
                    '.Value = dico.Item(r.Value)(0)
                    '.Interior.ColorIndex = dico.Item(r.Value)(1)
                     .Value = 1
                    .Interior.ColorIndex = 4
                End With
            End If
        Next
    End With
    Set dico = Nothing
    Application.ScreenUpdating = True
End Sub

klin89

Bonjour Klin89,

Désolé de répondre si tard. J'ai essayé vos lignes de code.

C'est juste bleufant, cela fonctionne à merveille. Exactement ce que je voulais.

1000 mercis.

C'est juste incroyable, je vous suis très reconnaissant.

Et encore merci.

ELAB