Macro copier - Coller selon interior.color

Bonjour,

N’étant pas un expert en VBA, je me tourne vers vous dans le but de réaliser une macro. Après des recherches sur internet, je n’ai pas réussi à adapter de code existant à mon problème.

Ce dernier est relativement simple : je souhaiterais faire un résumé, dans le feuillet 1, du feuillet 2, avec le classement comme qui suit:

• Si le total a un fond vert, ainsi que tous les sites, alors je souhaiterai copier dans le tableau 1 uniquement le Bâtiment ainsi que le Total
• Si le total a un fond orange ou vert, mais que les sites de sont pas tous en fond vert, alors recopier dans le tableau 2 le détail du bâtiment.
• Si le total a un fond rouge, alors recopier dans le tableau 5 le détail du bâtiment.

Les fonds sont établis avec une macro qui ne se trouve pas dans le fichier, à l'aide de "interior.color".

En PJ le fichier en question.

J’ai déjà fait la mise en forme des tableaux « résumés » dans le feuillet 1 pour vous illustrer la mise en page.

Merci d’avance pour votre aide, en espérant pouvoir comprendre le code que vous me proposerez 

Bonsoir,

Proposition à voir :

Sub Résumé()
    Dim Svv(), Svo(), Srx(), clr, n%, i%, j%, v%, o%, r%, vor%
    clr = Array(vbGreen, RGB(255, 153, 0), vbRed)
    With Worksheets("Etat")
        n = .Range("B" & .Rows.Count).End(xlUp).Row
        For i = 3 To n Step 2
            Select Case .Cells(i, 7).Interior.Color
                Case clr(0)
                    For j = 3 To 6
                        If .Cells(i, j).Interior.Color <> clr(0) Then vor = 1: Exit For
                    Next j
                Case clr(1): vor = 1
                Case clr(2): vor = 2
            End Select
            Select Case vor
                Case 0
                    v = v + 2: ReDim Preserve Svv(2, 1 To v)
                    Svv(2, v) = .Cells(i, 7): Svv(2, v - 1) = .Cells(i - 1, 7)
                    Svv(1, v) = .Cells(i, 2): Svv(1, v - 1) = .Cells(i - 1, 2)
                    Svv(0, v - 1) = .Cells(i - 1, 1)
                Case 1
                    o = o + 2: ReDim Preserve Svo(6, 1 To o)
                    For j = 2 To 7
                        Svo(j - 1, o) = .Cells(i, j): Svo(j - 1, o - 1) = .Cells(i - 1, j)
                    Next j
                    Svo(0, o - 1) = .Cells(i - 1, 1)
                Case 2
                    r = r + 2: ReDim Preserve Srx(6, 1 To r)
                    For j = 2 To 7
                        Srx(j - 1, r) = .Cells(i, j): Srx(j - 1, r - 1) = .Cells(i - 1, j)
                    Next j
                    Srx(0, r - 1) = .Cells(i - 1, 1)
            End Select
            vor = 0
        Next i
    End With
    With Worksheets("Résumé")
        .Range("A6:S45").ClearContents
        With .Range("A6")
            For i = 1 To v
                For j = 1 To 3
                    .Cells(i, j) = Svv(j - 1, i)
                Next j
            Next i
            For i = 1 To o
                For j = 5 To 11
                    .Cells(i, j) = Svo(j - 5, i)
                Next j
            Next i
            For i = 1 To r
                For j = 13 To 19
                    .Cells(i, j) = Srx(j - 13, i)
                Next j
            Next i
        End With
        .Activate
    End With
End Sub

Cordialement.