Microsoft 365 Macro perso trop lourde

Sub Copiercoller()
'd?claration des variables
Dim DerLigne1 As Long, DerLigne2, tablo
Indicateurs_collage = "Indicateurs_Collage_2020.xlsm"
'---------------------------
Application.ScreenUpdating = False
'---------------------------
'ETAPE 1 : v?rifier que les 2 fichiers BDDS sont bien ouverts
'---------------------------
Dim wb As Workbook
For Each wb In Workbooks
If wb.Name Like "XFRGOGE _" & "*" & ".XLS" Then fichier1 = 1
If wb.Name Like "intraprint2xls_010_" & "*" & ".xls" Then fichier2 = 1
Next wb
If fichier1 + fichier2 < 2 Then
MsgBox ("Il faut ouvrir les 2 extractions avant d'activer la macro !")
Workbooks(Indicateurs_collage).Close
Exit Sub
End If
' ETAPE 2 : copier les 2 fichiers AS400 puis les fermer
'---------------------------
'nettoyer l'onglet AS400
Workbooks(Indicateurs_collage).Sheets("Extraction_AS400").Range("A2:Y65000").ClearContents
'Workbooks(Indicateurs_collage).Sheets("Extraction_Intraprint").Range("A2:Y65000").ClearContents

'copier les donnees Intraprint
For Each wb In Workbooks
If wb.Name Like "intraprint2xls_010_" & "*" & ".xls" Then

fichierintraprint = wb.Name
Workbooks(fichierintraprint).Sheets(1).Activate
Range("A2:Y65000").Select
Selection.Copy

Workbooks(Indicateurs_collage).Sheets("Extraction_Intraprint").Activate
Dim Dl%
Dl = Range("A" & Rows.Count).End(xlUp).Row + 1
Range("A" & Dl).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Workbooks(fichierintraprint).Close
End If
Next wb
For Each wb In Workbooks
'copier les donnees AS400
If wb.Name Like "XFRGOGE _" & "*" & ".XLS" Then

fichierAS400 = wb.Name
Workbooks(fichierAS400).Sheets(1).Activate
tablo = Range("A2:Y65000")  ' Transfert des données dans un array

Workbooks(Indicateurs_collage).Sheets("Extraction_AS400").Range("A2:Y65000").Resize(UBound(tablo)) = tablo  ' Transfert de l'array dans la feuille
Workbooks(fichierAS400).Close
End If
Next wb
End Sub

Sub Copiercoller()
'd?claration des variables
    'Indicateurs_collage = "Indicateurs_Collage_2020.xlsm"
        Dim WkIndiCollage as Workbook
            Set WkIndiCollage = Workbooks("Indicateurs_Collage_2020.xlsm")
        Dim SHExtraction_AS400 as Worksheet
            Set SHExtraction_AS400 = WkIndiCollage.Worksheets("Extraction_AS400")
        Dim Extraction_Intraprint as Worksheet
            Set Extraction_Intraprint = WkIndiCollage.Worksheets("Extraction_Intraprint")

'---------------------------
    Application.ScreenUpdating = False
'---------------------------
'    ETAPE 1 : v?rifier que les 2 fichiers BDDS sont bien ouverts
'---------------------------
    Dim wb As Workbook
        For Each wb In Workbooks
            If wb.Name Like "XFRGOGE _" & "*" & ".XLS" Then fichier1 = 1
            If wb.Name Like "intraprint2xls_010_" & "*" & ".xls" Then fichier2 = 1
        Next wb
    If fichier1 + fichier2 < 2 Then
        MsgBox ("Il faut ouvrir les 2 extractions avant d'activer la macro !")
        'Workbooks(Indicateurs_collage).Close
        WkIndiCollage.Close
        Exit Sub
    End If
'---------------------------
' ETAPE 2 : copier les 2 fichiers AS400 puis les fermer
'---------------------------
'nettoyer l'onglet AS400
    'Workbooks(Indicateurs_collage).Sheets("Extraction_AS400").Range("A2:Y65000").ClearContents
    SHExtraction_AS400.Range("A2:Y65000").ClearContents

'copier les donn?es Intraprint
For Each wb In Workbooks
    If wb.Name Like "intraprint2xls_010_" & "*" & ".xls" Then
        'fichierintraprint = wb.Name
        'Workbooks(fichierintraprint).Sheets(1).Activate
        'Range("A2:Y65000").Select
        'Selection.Copy
        Dim Rgnfichierintraprint as Range
            Set Rgnfichierintraprint = wb.Sheets(1).Range("A2:Y65000")
   
        'Workbooks(Indicateurs_collage).Sheets("Extraction_Intraprint").Activate
        'Dim Dl%
        'Dl = Range("A" & Rows.Count).End(xlUp).Row + 1
        'Range("A" & Dl).Select
        'ActiveSheet.Paste
            'Application.CutCopyMode = False
        Rgnfichierintraprint.Copy Destination:=Extraction_Intraprint.Range("A" & Extraction_Intraprint.Range("A" & Rows.Count).End(xlUp).Row + 1)
   
        'Workbooks(fichierintraprint).Close
        wb.Close
    End If
Next wb

For Each wb In Workbooks
'copier les donn?es AS400
    If wb.Name Like "XFRGOGE _" & "*" & ".XLS" Then
        'fichierAS400 = wb.Name
        'Workbooks(fichierAS400).Sheets(1).Activate
        'Range("A2:Y65000").Select
        'Selection.Copy
        Dim RgnfichierAS400 as Range
            Set RgnfichierAS400 = wb.Sheets(1).Range("A2:Y65000")

        'Workbooks(Indicateurs_collage).Sheets("Extraction_AS400").Activate
        'Range("A2:Y65000").Select
        'ActiveSheet.Paste
        'Application.CutCopyMode = False
        RgnfichierAS400.Copy Destination:= SHExtraction_AS400.Range("A2:Y65000")
   
        'Workbooks(fichierAS400).Close
        wb.Close
    End If
Next wb

End Sub

Sub Copiercoller()
'd?claration des variables
    'Indicateurs_collage = "Indicateurs_Collage_2020.xlsm"
        Dim WkIndiCollage as Workbook
            Set WkIndiCollage = Workbooks("Indicateurs_Collage_2020.xlsm")
        Dim SHExtraction_AS400 as Worksheet
            Set SHExtraction_AS400 = WkIndiCollage.Worksheets("Extraction_AS400")
        Dim Extraction_Intraprint as Worksheet
            Set Extraction_Intraprint = WkIndiCollage.Worksheets("Extraction_Intraprint")
'---------------------------
'    ETAPE 1 : v?rifier que les 2 fichiers BDDS sont bien ouverts
'---------------------------
    Dim wb As Workbook
        For Each wb In Workbooks
            If wb.Name Not Like "XFRGOGE _" & "*" & ".XLS" Then MsgBox ("Il faut ouvrir les 2 extractions avant d'activer la macro !") : WkIndiCollage.Close : Exit Sub
            If wb.Name Not Like "intraprint2xls_010_" & "*" & ".xls" Then MsgBox ("Il faut ouvrir les 2 extractions avant d'activer la macro !") : WkIndiCollage.Close : Exit Sub
        Next wb
'---------------------------
' ETAPE 2 : copier les 2 fichiers AS400 puis les fermer
'---------------------------
'nettoyer l'onglet AS400
    SHExtraction_AS400.Range("A2:Y65000").ClearContents

For Each wb In Workbooks
    'copier les donn?es Intraprint
    If wb.Name Like "intraprint2xls_010_" & "*" & ".xls" Then
        Dim Rgnfichierintraprint as Range
            Set Rgnfichierintraprint = wb.Sheets(1).Range("A2:Y65000")
        Rgnfichierintraprint.Copy Destination:=Extraction_Intraprint.Range("A" & Extraction_Intraprint.Range("A" & Rows.Count).End(xlUp).Row + 1)
        wb.Close

    'copier les donn?es AS400
    ElseIf wb.Name Like "XFRGOGE _" & "*" & ".XLS" Then
        Dim RgnfichierAS400 as Range
            Set RgnfichierAS400 = wb.Sheets(1).Range("A2:Y65000")
        RgnfichierAS400.Copy Destination:= SHExtraction_AS400.Range("A2:Y65000")
        wb.Close
    End If
Next wb

End Sub

with workbooks(fichierintraprint).sheets(1)
derlig=.cells(.usedrange.cells.count).row
tableau=.Range("A2:Y" & derlig).value
end with
with Workbooks(Indicateurs_collage).Sheets("Extraction_Intraprint")
.Range("A" & Rows.Count).End(xlUp).offset(1).resize(ubound(tableau),ubound(tableau,2)=tableau
end with