Optimisation macro

Le 27/12/2022 à 16:10

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

Le 27/12/2022 à 17:31

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

Le 28/12/2022 à 09:00

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 ?

Le 28/12/2022 à 09:10

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

Le 28/12/2022 à 14:38

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

Le 29/12/2022 à 08:59

Bonjour;

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

Cdl,
Parrish