Copier cel +ieurs tab d'1onglet vers 1autre onglet

Bonjour le forum,

Je m’adresse particulièrement à klin89. Je profite, à nouveau, pour vous remercier pour la macro que vous avez déjà réalisée pour moi.

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

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

Dans la Feuil4, il y a des tableaux (TAB1 à TAB27) et dans la Feuil5, il y a 1 tableau (TAB_X).

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

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

Je me suis permis d’adapter votre macro pour que chaque N° de TAB de la Feuil4 correspondent à la colonne adéquate de la Feuil5 et chose extraordinaire cela marche.

Mais hélas, la macro ne tient pas compte les cellules à fond rouge. J’ai bien essayé d’ajouter ce paramètre supplémentaire sans succès.

Je vous invite donc à regarder les macros (la vôtre et la « mienne »), rester bien assis, vous risquez sinon de tomber à la renverse.

Merci d’avance.

ELAB

Bonjour ELAB,

Pour plus de clarté, j'ai épuré la Feuille4 de toutes tes annotations

A tester sur une copie de ton fichier original

Option Explicit
Sub test()
Dim i As Long, j As Long, k As Byte, txt As String
Dim myAreas As Areas, dico As Object
    Set dico = CreateObject("Scripting.Dictionary")
    dico.Comparemode = 1
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    With Sheets("Feuil4")
        '.Columns(1).SpecialCells(2).Select
        Set myAreas = .Columns(1).SpecialCells(2).Areas
        'On parcourt chaque zone
        For k = 1 To myAreas.Count
            With myAreas(k).CurrentRegion
                '.Select
                For i = 5 To .Rows.Count
                    For j = 2 To .Columns.Count
                        If .Cells(i, j).Interior.ColorIndex = 4 _
                           Or .Cells(i, j).Interior.ColorIndex = 3 Then
                            txt = .Cells(4, j).Value & .Cells(i, 1).Value & .Cells(1, 2).Value
                            dico.Item(txt) = .Cells(i, j).Interior.ColorIndex
                        End If
                    Next
                Next
            End With
        Next
    End With
    With Sheets("Feuil5")
        With .Range("b8", .Range("ab" & .Range("a" & .Rows.Count).End(xlUp).Row))
            '.Select
            .Interior.ColorIndex = xlNone
            .ClearContents
        End With
        With .Range("a4").CurrentRegion
            For i = 5 To .Rows.Count
                For j = 2 To .Columns.Count - 1
                    txt = .Cells(i, 1).Value & .Cells(3, j).Value
                    If dico.exists(txt) Then
                        With .Cells(i, j)
                            .Value = 1
                            .Interior.ColorIndex = dico.Item(txt)
                        End With
                    End If
                Next
            Next
        End With
    End With
    Set myAreas = Nothing
    Set dico = Nothing
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

klin89

Bonjour Klin89,

J'ai essayé la macro avec la nouvelle mise en forme que vous avez réalisé.

Elle fonctionne à merveille. Et je suis juste fou de joie.

Si cela ne vous dérange pas, pouvez-vous annoter les lignes de codes.

J'aimerais essayer de comprendre ce qui me parait un peu comme du "chinois".

Ce serait la cerise sur le gâteau.

Je vous suis très reconnaissant.

Merci, merci, et encore merci .....

Cordialement.

ELAB