Optimisation macro

Bonjour,

Je dois répéter cet macro pour 50 sociétés, j'ai peur qu'elle soit assez lourd, connaissez vous un moyen de réduire les étapes au lieu de recopier betment le code ?

SOC 1
With Sheets("Pilotage")
    ON_SOC1 = .Range("C24")
   REF_SOC1 = .Range("E24")
   PROV1_SOC1 = .Range("F24")
   PROV2_SOC1 = .Range("G24")
   OND_SOC1 = .Range("H24")
   DEST1_SOC1 = .Range("I24")
   DEST2_SOC1 = .Range("J24")
End With

if ON_SOC1 ="Oui" Then

    Application.Goto Sheets(REF_SOC1).Range(PROV1_SOC1 & ":" & PROV2_SOC1)
    Range(PROV1_SOC1 & ":" & PROV2_SOC1).Copy

' coller des données dans le fichier Synthèse SOC 3

   Windows(Fichier_destination & ".xlsm").Activate

    Application.Goto Sheets(OND_SOC1).Range(DEST1_SOC1)
    Range(DEST1_SOC1).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

        Windows(Fichier_source & ".xlsm").Activate
        Sheets("Pilotage").Select

End if

'SOC 2
With Sheets("Pilotage")
    ON_SOC2 = .Range("C25")
   REF_SOC2 = .Range("E25")
   PROV1_SOC2 = .Range("F25")
   PROV2_SOC2 = .Range("G25")
   OND_SOC2 = .Range("H25")
   DEST1_SOC2 = .Range("I25")
   DEST2_SOC2 = .Range("J25")
End With

if ON_SOC2 ="Oui" Then

    Application.Goto Sheets(REF_SOC2).Range(PROV1_SOC2 & ":" & PROV2_SOC2)
    Range(PROV1_SOC2 & ":" & PROV2_SOC2).Copy

' coller des données dans le fichier Synthèse SOC 3

   Windows(Fichier_destination & ".xlsm").Activate

    Application.Goto Sheets(OND_SOC2).Range(DEST1_SOC2)
    Range(DEST1_SOC2).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

        Windows(Fichier_source & ".xlsm").Activate
        Sheets("Pilotage").Select

End if

End Sub

Merci d'avance,

Cordialement,
Parrish

Bonsoir,

une proposition :

Sub Société25()
    With Sheets("Pilotage")
        For i = 24 To 49
            ON_SOC = .Range("C" & i)
            If ON_SOC = "Oui" Then
                REF_SOC = .Range("E" & i)
                PROV1_SOC = .Range("F" & i)
                PROV2_SOC = .Range("G" & i)
                OND_SOC = .Range("H" & i)
                DEST1_SOC = .Range("I" & i)
                DEST2_SOC = .Range("J" & i)

                '******************************************************************
                Application.Goto Sheets(REF_SOC).Range(PROV1_SOC & ":" & PROV2_SOC)
                Range(PROV1_SOC & ":" & PROV2_SOC).Copy
                Windows(Fichier_destination & ".xlsm").Activate
                Application.Goto Sheets(OND_SOC).Range(DEST1_SOC)
                Range(DEST1_SOC).Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                Windows(Fichier_source & ".xlsm").Activate
                '******************************************************************

'                ' voir si ceci fonctionne à la place de ce qu'il y a ci dessus entre les "*"
'                Sheets(REF_SOC).Range(PROV1_SOC & ":" & PROV2_SOC).Copy Destination:= _
'                    Workbook(Fichier_destination & ".xlsm").Sheets(OND_SOC).Range(DEST1_SOC)
            End If
        Next i
    End With
End Sub

@ bientôt

LouReeD

Bonjour LouReeD,

tout semble marché, merci beaucoup ^^

Cela me fait gagner beaucoup de temps !

Pour bien comprendre il s'agit du I = 24 To 49 pour définir les Dimensions

Et le Next I pour passer à la suivante ?

Voila macro final :

Merci à LouReeD :

Sub collage()

'Début d'optimisation
Application.ScreenUpdating = False

Dim Fichier_destination
Dim Fichier_source

    Fichier_destination = Range("D11").Value
    Fichier_source = Range("D9").Value

    With Sheets("Pilotage")
        For i = 17 To 68
            ON_SOC = .Range("C" & i)
            If ON_SOC = "Oui" Then
                REF_SOC = .Range("E" & i)
                PROV1_SOC = .Range("F" & i)
                PROV2_SOC = .Range("G" & i)
                OND_SOC = .Range("H" & i)
                DEST1_SOC = .Range("I" & i)
                DEST2_SOC = .Range("J" & i)

                '******************************************************************
                Application.Goto Sheets(REF_SOC).Range(PROV1_SOC & ":" & PROV2_SOC)
                Range(PROV1_SOC & ":" & PROV2_SOC).Copy
                Windows(Fichier_destination & ".xlsm").Activate
                Application.Goto Sheets(OND_SOC).Range(DEST1_SOC)
                Range(DEST1_SOC).Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                Windows(Fichier_source & ".xlsm").Activate
                '******************************************************************

            End If
        Next i
    End With

'Fin d'opitmisation
Application.ScreenUpdating = True

End Sub

Bonjour,

merci pour ce retour !

Avez-vous essayé en remplaçant le code entre "*" avec celui fourni en 'commentaire ?
Selon le type de copie que vous voulez faire c'est peut-être plus simple ou alors complètement à côté de la plaque voir même il n'a pas fonctionné !

@ bientôt

LouReeD

Bonjour;

Oui, pour avoir tester, je reçoit un message d'erreur de fonction

Cdl,
Parrish

Rechercher des sujets similaires à "optimisation macro"