Copier des éléments de plusieurs feuille pour en faire une synthese

[ludo93]

Bonjour

Je relance le sujet pour voir si quelqu'un aurai une idée pour résoudre ce case tête pour ma part.
le fichier aura plus d'un centaine de fiche qui ce présente de la même façons sauf hélas dans quelque cas
Ceux qui fausse la macro actuelle

Merci d'avance de votre retour

 

[Regueiro]

Bonsoir Le Forum
Tu dois refaire une 2ème boucle pour rechercher le terme objectif dans la colonne A :

Option Explicit
Sub Synthèse_autre_cas()
    Dim o As Object, sy As Object
    Dim Cel As Range
    Set sy = Sheets("synthese")
    With Application: .ScreenUpdating = False: .Calculation = xlManual: .EnableEvents = False: End With
    sy.Activate
    Range("a4:j65000").Clear
    For Each o In Worksheets
        If o.Name <> "synthese" And o.Range("A5") Like "Nom*" Then
            o.Range("b4").Copy sy.Range("a" & Rows.Count).End(xlUp)(2)
            o.Range("b5").Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 1)
            o.Range("f4").Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 2)
            For Each Cel In o.Range("A1:A50")
                If Cel.Value = "Objectif" Then
                    Cel.Offset(, 2).Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 3)   'C22
                    Cel.Offset(-1, 3).Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 4)   'D21
                    Cel.Offset(, 3).Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 5)   'D22 Erreur chez toi
                    Cel.Offset(-1, 4).Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 6)   'E21
                    Cel.Offset(, 4).Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 7)   'E22
                    Cel.Offset(-1, 5).Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 8)   'F21
                    Cel.Offset(, 5).Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 9)   'F22

                   

                   
                End If
            Next Cel
                       
           ' o.Range("c22").Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 3)
           ' o.Range("d21").Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 4)
          '  o.Range("c22").Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 5)
           ' o.Range("e21").Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 6)
            'o.Range("e22").Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 7)
          '  o.Range("f21").Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 8)
           ' o.Range("e12").Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 9)

        End If
    Next
    Range("a4").CurrentRegion.Borders.Value = 1
    With Application: .EnableEvents = True: .Calculation = xlAutomatic: .ScreenUpdating = True: End With
End Sub

 

[Regueiro]

RE
Bon code avec recherche pour la base variable

Option Explicit
Sub Synthèse_autre_cas()
    Dim o As Object, sy As Object
    Dim Cel As Range
    Set sy = Sheets("synthese")
    With Application: .ScreenUpdating = False: .Calculation = xlManual: .EnableEvents = False: End With
    sy.Activate
    Range("a4:j65000").Clear
    For Each o In Worksheets
        If o.Name <> "synthese" And o.Range("A5") Like "Nom*" Then
            o.Range("b4").Copy sy.Range("a" & Rows.Count).End(xlUp)(2)
            o.Range("b5").Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 1)
            o.Range("f4").Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 2)
            For Each Cel In o.Range("A1:A50")
                If Cel.Value = "Objectif" Then
                    Cel.Offset(, 2).Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 3)   'C22
                    Cel.Offset(-1, 3).Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 4)   'D21
                    Cel.Offset(, 3).Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 5)   'D22 Erreur chez toi
                    Cel.Offset(-1, 4).Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 6)   'E21
                    Cel.Offset(, 4).Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 7)   'E22
                    Cel.Offset(-1, 5).Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 8)   'F21
                   
                End If
            Next Cel
            For Each Cel In o.Range("B1:B50")
                If Cel.Value = "Base variable" Then
                    Cel.Offset(, 1).Copy sy.Range("a" & Rows.Count).End(xlUp).Offset(, 9)   'E12
                    'Attention cellule fusionnée
                End If
            Next Cel
    
        End If
    Next
    Range("a4").CurrentRegion.Borders.Value = 1
    With Application: .EnableEvents = True: .Calculation = xlAutomatic: .ScreenUpdating = True: End With
End Sub

 

[ludo93]

Je te remercie pour ce retour rapide
Je pourrais tester seulement lundi le fichier au complet mais vue le 1er teste cela correspond au résultat voulue.