Extraction de données complexe

[B]Public Const noMaxFeuille As Integer = 2[/B]


Sub test()
Dim noFeuille As Integer, ligneItem As Integer, ligneItemRecherche As Integer
Dim memAdresse As String
Dim cellRecherche As Range
Dim feuilleResultat As Worksheet

    Set feuilleResultat = ThisWorkbook.Sheets("résultat")
    For ligneItem = 2 To feuilleResultat.Range("A" & feuilleResultat.Rows.Count).End(xlUp).Row
        For noFeuille = 1 To noMaxFeuille
            With ThisWorkbook.Sheets("vernis poste " & CStr(noFeuille))
                Set cellRecherche = .Columns("A").Find(feuilleResultat.Range("A" & ligneItem), , xlValues, xlWhole)
                If Not cellRecherche Is Nothing Then
                    ligneItemRecherche = cellRecherche.Row
                    Set cellRecherche = .Rows(1).Find("vernis", , xlValues, xlPart, , False)
                    If Not cellRecherche Is Nothing Then
                        memAdresse = cellRecherche.Address
                        Do
                            feuilleResultat.Cells(ligneItem, feuilleResultat.Columns.Count).End(xlToLeft).Offset(0, 1).Value = .Cells(ligneItemRecherche, cellRecherche.Column).Text
                            Set cellRecherche = .Rows(1).FindNext(cellRecherche)
                        Loop Until cellRecherche.Address = memAdresse
                    End If
                End If
            End With
        Next
    Next ligneItem
End Sub

Sub test()
Dim noFeuille As Integer, ligneItem As Integer, ligneItemRecherche As Integer
Dim memAdresse As String
Dim cellRecherche As Range
Dim feuilleResultat As Worksheet[COLOR=Red][B], curSheet As Worksheet[/B][/COLOR]

    Set feuilleResultat = ThisWorkbook.Sheets("résultat")
    For ligneItem = 2 To feuilleResultat.Range("A" & feuilleResultat.Rows.Count).End(xlUp).Row
        [COLOR=Red][B]For Each curSheet In ThisWorkbook.Sheets(Array("CC COLLE", "ENDUCTION VERNIS", "bon CCR + PERFO", "CC CIRE", "ENDUCTION CIRE"))[/B][/COLOR]
            With curSheet
                Set cellRecherche = .Columns("A").Find(feuilleResultat.Range("A" & ligneItem), , xlValues, xlWhole)
                If Not cellRecherche Is Nothing Then
                    ligneItemRecherche = cellRecherche.Row
                    Set cellRecherche = .Rows(1).Find("vernis", , xlValues, xlPart, , False)
                    If Not cellRecherche Is Nothing Then
                        memAdresse = cellRecherche.Address
                        Do
                            feuilleResultat.Cells(ligneItem, feuilleResultat.Columns.Count).End(xlToLeft).Offset(0, 1).Value = .Cells(ligneItemRecherche, cellRecherche.Column).Text
                            Set cellRecherche = .Rows(1).FindNext(cellRecherche)
                        Loop Until cellRecherche.Address = memAdresse
                    End If
                End If
            End With
        [B][COLOR=Red]Next curSheet[/COLOR][/B]
    Next ligneItem
End Sub