Microsoft 365 Macro perso trop lourde

Coralie01120 · 8 Septembre 2020

Bonjour,

J'ai crée cette macro perso qui fonctionne à merveille. Toutefois, elle est beaucoup trop lourde, mon PC rame pendant 5min...
Auriez vous une solution pour l'alléger un peu ?

Sub Copiercoller()
'd?claration des variables
Dim DerLigne1 As Long, DerLigne2
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 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

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 donn?es AS400
If wb.Name Like "XFRGOGE _" & "*" & ".XLS" Then

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

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

Je vous mremercie pour votre aide.

sylvanu · 8 Septembre 2020

Bonsoir Coralie,
A2:Y65000 ça fait 1624975 cellules à copier/coller. Ca fait beaucoup.

Mais juste une question au sujet de votre code.
Vous prenez tous les fichiers qui contiennent "XFRGOGE _" & "*" & ".XLS", et vous copiez "A2:Y65000".
Après vous sélectionnez Workbooks(Indicateurs_collage).Sheets("Extraction_AS400").Activate et vous collez.
J'ai l'impression que vous collez toujours au même endroit en Indicateurs_Collage_2020.xlsm/Extraction_AS400/Range( "A2:Y65000" )

Où ai je raté un épisode ?

sylvanu · 8 Septembre 2020

Sinon essayez ça en passant par un array, ce sera peut être plus rapide :

VB:

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

laurent950 · 8 Septembre 2020

Bonsoir
Peux être comme cela avec Variable Objet.

VB:

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

Simplifier

VB:

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

ChTi160 · 8 Septembre 2020

Bonsoir
Bonsoir le Fil ,le Forum
Pourquoi copier la plage

VB:

Range("A2:Y65000")

et pas par exemple

VB:

Range("A2:Y" & Cells(Rows.count,1).End(xlup).row

juste une Idée lol
jean marie

Coralie01120 · 9 Septembre 2020

Bonsoir,

Merci pour votre aide !
C'est beaucoup plus rapide

patricktoulon · 9 Septembre 2020

bonsoir
c'est toujours le meme probleme quand on utilise le xlup d'une colonne pour une plage
il est pas dit que le xlup de "A" soit la derniere ligne valide

perso je fait comme ca

with workbooks(x).sheets(y)
derlig=.cells(.usedrange.cells.count).row
.Range("A2:Y" & derlig)
end with

j'ajouterais que si tout les classeurs sont ouverts on utilise ma méthode mais en tableau sans jamais déactiver le classeur de destination

autrement dit si je reprends le code
je remplace ca
Workbooks(fichierintraprint).Sheets(1).Activate
Range("A2:Y65000").Select
Selection.Copy
'blablabla
'blablabla

par cela

VB:

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

là on est sur de pas perdre des lignes

et plus rapide que ça pas possible

ChTi160 · 9 Septembre 2020

Bonsoir Patrick
Effectivement c'est plus secure lol
Merci
Je vais y regarder pour une meilleure utilisation dans l'avenir.
Amicalement
Jean marie

patricktoulon · 9 Septembre 2020

bonsoir ChTi160
with sheets(x)
set dernierecellule=.cells(.usedrange.cells.count)
msgbox dernierecellule.address(0,0)
end with

donne l'adress de la derniere cellule en bas a droite du rectangle(usedrange)

ChTi160 · 9 Septembre 2020

Re
Merci
Y'a pas de problème si la feuille contient plusieurs tableaux?
Jean marie

patricktoulon · 9 Septembre 2020

si !!!!!! là c'est différent il faut utiliser currentregion a la place de usedrange à condition qu'il y est au moins une colonne de vide ou une ligne de vide entre chaque tableau

ChTi160 · 9 Septembre 2020

Re
Merci
Jean marie

Effectuez une recherche sur Excel Downloads...

Microsoft 365 Macro perso trop lourde

Coralie01120

XLDnaute Occasionnel

ChTi160

sylvanu

XLDnaute Barbatruc

sylvanu

XLDnaute Barbatruc

laurent950

XLDnaute Accro

ChTi160

XLDnaute Barbatruc

Coralie01120

XLDnaute Occasionnel

patricktoulon

XLDnaute Barbatruc

ChTi160

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

ChTi160

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

ChTi160

XLDnaute Barbatruc

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums