Comment optimiser ce code ?

Le 09/03/2022 à 14:05

Bonjour,

Je souhaiterai optimiser le temps de fonctionnement de cette macro comment puis je le faire ?

En sachant que dans ma logique, je vais chercher des feuilles dans d'autres classeurs, je les renomme, et ensuite je vais chercher des données afin de recopier les lignes qui contiennent ces données dans une autre feuille.

Merci au forumeurs qui voudront bien m'aider s'il vous plait.

Sub CopierFeuilleDuClasseurFermé()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'USFWait.Show 0
  'USFWait.Repaint

Call efface

Set classeurFermé = Workbooks.Open("C:\Users\salva\OneDrive\Bureau\Isa\Tableau gestionnaire ANZIN 1.xlsx", 0, True)
    classeurFermé.Sheets("ASE").Copy Before:=ThisWorkbook.Sheets(1)
    classeurFermé.Close SaveChanges:=False
ActiveSheet.Name = "ASE ANZIN 1"
Columns("D:D").Delete Shift:=xlToLeft
''
Set classeurFermé = Workbooks.Open("C:\Users\salva\OneDrive\Bureau\Isa\Tableau gestionnaire ANZIN 2.xlsx", 0, True)
    classeurFermé.Sheets("ASE").Copy Before:=ThisWorkbook.Sheets(1)
    classeurFermé.Close SaveChanges:=False
ActiveSheet.Name = "ASE ANZIN 2"
'''
Set classeurFermé = Workbooks.Open("C:\Users\salva\OneDrive\Bureau\Isa\Tableau gestionnaire CONDE 1.xlsx", 0, True)
    classeurFermé.Sheets("ASE").Copy Before:=ThisWorkbook.Sheets(1)
    classeurFermé.Close SaveChanges:=False
ActiveSheet.Name = "ASE CONDE 1"
Range("A1").EntireColumn.Insert
Range("A1").EntireColumn.Insert
''''
Set classeurFermé = Workbooks.Open("C:\Users\salva\OneDrive\Bureau\Isa\Tableau gestionnaire CONDE 2.xlsx", 0, True)
    classeurFermé.Sheets("ASE").Copy Before:=ThisWorkbook.Sheets(1)
    classeurFermé.Close SaveChanges:=False
ActiveSheet.Name = "ASE CONDE 2"
Range("A1").EntireColumn.Insert
Range("A1").EntireColumn.Insert
'''''
Set classeurFermé = Workbooks.Open("C:\Users\salva\OneDrive\Bureau\Isa\Tableau gestionnaire VALENCIENNES 1.xlsx", 0, True)
    classeurFermé.Sheets("ASE").Copy Before:=ThisWorkbook.Sheets(1)
    classeurFermé.Close SaveChanges:=False
ActiveSheet.Name = "ASE VALENCIENNES 1"
Columns("E:E").Delete Shift:=xlToLeft
''''''
Set classeurFermé = Workbooks.Open("C:\Users\salva\OneDrive\Bureau\Isa\Tableau gestionnaire VALENCIENNES 2.xlsx", 0, True)
    classeurFermé.Sheets("ASE").Copy Before:=ThisWorkbook.Sheets(1)
    classeurFermé.Close SaveChanges:=False
ActiveSheet.Name = "ASE VALENCIENNES 2"
Columns("C:C").Delete Shift:=xlToLeft
'''''''
Set classeurFermé = Workbooks.Open("C:\Users\salva\OneDrive\Bureau\Isa\Tableau gestionnaire ONNAING.xlsx", 0, True)
    classeurFermé.Sheets("ASE").Copy Before:=ThisWorkbook.Sheets(1)
    classeurFermé.Close SaveChanges:=False
ActiveSheet.Name = "ASE ONNAING"
''''''''
Set classeurFermé = Workbooks.Open("C:\Users\salva\OneDrive\Bureau\Isa\Tableau gestionnaire ST AMAND.xlsx", 0, True)
    classeurFermé.Sheets("ASE").Copy Before:=ThisWorkbook.Sheets(1)
    classeurFermé.Close SaveChanges:=False
ActiveSheet.Name = "ASE ST AMAND"
'''''''''
Set classeurFermé = Workbooks.Open("C:\Users\salva\OneDrive\Bureau\Isa\Tableau gestionnaire DENAIN BOUCHAIN 1.xlsx", 0, True)
    classeurFermé.Sheets("ASE").Copy Before:=ThisWorkbook.Sheets(1)
    classeurFermé.Close SaveChanges:=False
ActiveSheet.Name = "ASE DENAIN BOUCHAIN 1"
''''''''''
Set classeurFermé = Workbooks.Open("C:\Users\salva\OneDrive\Bureau\Isa\Tableau gestionnaire DENAIN BOUCHAIN 2.xlsx", 0, True)
    classeurFermé.Sheets("ASE").Copy Before:=ThisWorkbook.Sheets(1)
    classeurFermé.Close SaveChanges:=False
ActiveSheet.Name = "ASE DENAIN BOUCHAIN 2"
'''''''''
Set classeurFermé = Workbooks.Open("C:\Users\salva\OneDrive\Bureau\Isa\Tableau gestionnaire DENAIN LOURCHES 1.xlsx", 0, True)
    classeurFermé.Sheets("ASE").Copy Before:=ThisWorkbook.Sheets(1)
    classeurFermé.Close SaveChanges:=False
ActiveSheet.Name = "ASE DENAIN LOURCHES 1"
''''''''''
Set classeurFermé = Workbooks.Open("C:\Users\salva\OneDrive\Bureau\Isa\Tableau gestionnaire DENAIN LOURCHES 2.xlsx", 0, True)
    classeurFermé.Sheets("ASE").Copy Before:=ThisWorkbook.Sheets(1)
    classeurFermé.Close SaveChanges:=False
ActiveSheet.Name = "ASE DENAIN LOURCHES 2"

Call CopyRows_Garde

Sheets("LISTE").Activate
Range("A:D,K:N,P:P,V:W,AC:AG,AJ:AN,BC:BD").Select
Range("BD1").Activate
Selection.Delete Shift:=xlToLeft

Sheets("LISTE").Activate
Range("A2:BD3000").Copy Worksheets("ASE").Range("A2")

Sheets("ASE").Activate
With Range("A2:BD3000")
    .HorizontalAlignment = xlHAlignCenter
    .VerticalAlignment = xlVAlignCenter
Call aa2
End With

Call retirer

Sheets("LANCEMENT").Select

'Unload USFWait

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub
Sub retirer()
    Dim ws As Worksheet
    For Each ws In Worksheets
    'Application.DisplayAlerts = False
        If ws.Name <> "ASE" And ws.Name <> "LANCEMENT" And ws.Name <> "AEMO, AEMO+TDC, AEMO-R" Then ws.Delete
    Next
    'Application.DisplayAlerts = True
End Sub

Public Sub CopyRows_Garde()
Dim xWs As Worksheet
Dim xCWs As Worksheet
Dim xRg As Range
Dim xStrName As String
Dim xRStr As String
Dim xAStr As String
Dim xPStr As String
Dim xRRg As Range
Dim xC As Integer
On Error Resume Next
'Application.DisplayAlerts = False
xStr = "LISTE"
xJtr = "LISTE AEMO"
xBtr = "AEMO, AEMO+TDC, AEMO-R"
xCtr = "LISTE ASE"
xRStr = "GARDE"
xAStr = "AP"
xPStr = "Pupille"
xMStr = "AP Mère/Enfant"
xDStr = "DAP"
xTStr = "Tutelle"
xCStr = ""
Set xCWs = ActiveWorkbook.Worksheets.Item(xStr)
If Not xCWs Is Nothing Then
    xCWs.Delete
End If
Set xCWs = ActiveWorkbook.Worksheets.Add
xCWs.Name = xStr
xC = 1
For Each xWs In ActiveWorkbook.Worksheets
    If xWs.Name <> "xStr" And xWs.Name <> "xJtr" And xWs.Name <> "xBtr" And xWs.Name <> "xCtr" Then
        Set xRg = xWs.Range("S:S")
        Set xRg = Intersect(xRg, xWs.UsedRange)
        For Each xRRg In xRg
            If xRRg.Value = xRStr Then
               xRRg.EntireRow.Copy
               xCWs.Cells(xC, 1).PasteSpecial xlPasteValuesAndNumberFormats
               xC = xC + 1
            End If
        Next xRRg
    End If
Next xWs
For Each xWs In ActiveWorkbook.Worksheets
    If xWs.Name <> "xStr" And xWs.Name <> "xJtr" And xWs.Name <> "xBtr" And xWs.Name <> "xCtr" Then
        Set xRg = xWs.Range("S:S")
        Set xRg = Intersect(xRg, xWs.UsedRange)
        For Each xRRg In xRg
            If xRRg.Value = xAStr Then
               xRRg.EntireRow.Copy
               xCWs.Cells(xC, 1).PasteSpecial xlPasteValuesAndNumberFormats
               xC = xC + 1
            End If
        Next xRRg
    End If
Next xWs
For Each xWs In ActiveWorkbook.Worksheets
    If xWs.Name <> "xStr" And xWs.Name <> "xJtr" And xWs.Name <> "xBtr" And xWs.Name <> "xCtr" Then
        Set xRg = xWs.Range("S:S")
        Set xRg = Intersect(xRg, xWs.UsedRange)
        For Each xRRg In xRg
            If xRRg.Value = xPStr Then
               xRRg.EntireRow.Copy
               xCWs.Cells(xC, 1).PasteSpecial xlPasteValuesAndNumberFormats
               xC = xC + 1
            End If
        Next xRRg
    End If
Next xWs
For Each xWs In ActiveWorkbook.Worksheets
    If xWs.Name <> "xStr" And xWs.Name <> "xJtr" And xWs.Name <> "xBtr" And xWs.Name <> "xCtr" Then
        Set xRg = xWs.Range("S:S")
        Set xRg = Intersect(xRg, xWs.UsedRange)
        For Each xRRg In xRg
            If xRRg.Value = xMStr Then
               xRRg.EntireRow.Copy
               xCWs.Cells(xC, 1).PasteSpecial xlPasteValuesAndNumberFormats
               xC = xC + 1
            End If
        Next xRRg
    End If
Next xWs
For Each xWs In ActiveWorkbook.Worksheets
    If xWs.Name <> "xStr" And xWs.Name <> "xJtr" And xWs.Name <> "xBtr" And xWs.Name <> "xCtr" Then
        Set xRg = xWs.Range("S:S")
        Set xRg = Intersect(xRg, xWs.UsedRange)
        For Each xRRg In xRg
            If xRRg.Value = xDStr Then
               xRRg.EntireRow.Copy
               xCWs.Cells(xC, 1).PasteSpecial xlPasteValuesAndNumberFormats
               xC = xC + 1
            End If
        Next xRRg
    End If
Next xWs
For Each xWs In ActiveWorkbook.Worksheets
    If xWs.Name <> "xStr" And xWs.Name <> "xJtr" And xWs.Name <> "xBtr" And xWs.Name <> "xCtr" Then
        Set xRg = xWs.Range("S:S")
        Set xRg = Intersect(xRg, xWs.UsedRange)
        For Each xRRg In xRg
            If xRRg.Value = xTStr Then
               xRRg.EntireRow.Copy
               xCWs.Cells(xC, 1).PasteSpecial xlPasteValuesAndNumberFormats
               xC = xC + 1
            End If
        Next xRRg
    End If
Next xWs
For Each xWs In ActiveWorkbook.Worksheets
    If xWs.Name <> "xStr" And xWs.Name <> "xJtr" And xWs.Name <> "xBtr" And xWs.Name <> "xCtr" Then
        Set xRg = xWs.Range("S:S")
        Set xRg = Intersect(xRg, xWs.UsedRange)
        For Each xRRg In xRg
            If xRRg.Value = xCStr Then
               xRRg.EntireRow.Copy
               xCWs.Cells(xC, 1).PasteSpecial xlPasteValuesAndNumberFormats
               xC = xC + 1
            End If
        Next xRRg
    End If
Next xWs
'Application.DisplayAlerts = True
End Sub
Sub efface()
Worksheets("ASE").Range("A2:BZ3000").Clear
End Sub
Sub aa2()
Dim i&
For i& = 2 To 2000 'ligne 2 à ligne 21
  With Application.WorksheetFunction
   Range("E" & i&) = .RoundDown(.YearFrac(Now, Range("C" & i&)), 0)
  End With
Next i&
End Sub
Le 11/03/2022 à 18:46

Bonjour

Dans ce code Public Sub CopyRows_Garde(), pourquoi répétez-vous 7 fois la même boucle --> For Each xWs In ActiveWorkbook.Worksheets ?

Sinon pour le code Sub CopierFeuilleDuClasseurFermé(), essayez en modifiant le début du code jusqu'à l'instrcution --> Call CopyRows_Garde

Sub CopierFeuilleDuClasseurFermé()
Dim fichier()
Dim i As Byte

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Call efface

fichier = Array("Tableau gestionnaire ANZIN 1.xlsx", "Tableau gestionnaire ANZIN 2.xlsx", _
"Tableau gestionnaire CONDE 1.xlsx", "Tableau gestionnaire CONDE 2.xlsx", _
"Tableau gestionnaire VALENCIENNES 1.xlsx", "Tableau gestionnaire VALENCIENNES 2.xlsx", _
"Tableau gestionnaire ONNAING.xlsx", "Tableau gestionnaire ST AMAND.xlsx", _
"Tableau gestionnaire DENAIN BOUCHAIN 1.xlsx", "Tableau gestionnaire DENAIN BOUCHAIN 2.xlsx", _
"Tableau gestionnaire DENAIN LOURCHES 1.xlsx", "Tableau gestionnaire DENAIN LOURCHES 2.xlsx")

For i = LBound(fichier) To UBound(fichier)

    Workbooks(fichier).Sheets("ASE").Copy Before:=ThisWorkbook.Sheets(1)
    ActiveSheet.Name = "ASE " & Mid(Split(fichier(i), ".")(0), 22)
    Workbooks(fichier).Close savechanges:=False

Next i
Call CopyRows_Garde
'....le reste de votre code actuel
Le 11/03/2022 à 19:52

Merci Dan,

Je répéte 7 fois la même boucle car je n'arrive pas à manipuler mes différentes valeurs de recherche dans les colonnes, je n'arrivez pas à modifier la syntaxe pour tout mettre sur une seule boucle ...

For Each xWs In ActiveWorkbook.Worksheets
    If xWs.Name <> "xStr" And xWs.Name <> "xJtr" And xWs.Name <> "xBtr" And xWs.Name <> "xCtr" Then
        Set xRg = xWs.Range("S:S")
        Set xRg = Intersect(xRg, xWs.UsedRange)
        For Each xRRg In xRg
            If xRRg.Value = xRStr Then
               xRRg.EntireRow.Copy
               xCWs.Cells(xC, 1).PasteSpecial xlPasteValuesAndNumberFormats
               xC = xC + 1
            End If
        Next xRRg
    End If
Next xWs
For Each xWs In ActiveWorkbook.Worksheets
    If xWs.Name <> "xStr" And xWs.Name <> "xJtr" And xWs.Name <> "xBtr" And xWs.Name <> "xCtr" Then
        Set xRg = xWs.Range("S:S")
        Set xRg = Intersect(xRg, xWs.UsedRange)
        For Each xRRg In xRg
            If xRRg.Value = xAStr Then
               xRRg.EntireRow.Copy
               xCWs.Cells(xC, 1).PasteSpecial xlPasteValuesAndNumberFormats
               xC = xC + 1
            End If
        Next xRRg
    End If
Next xWs

Par exemple xRStr est le mot clé de recherche sur cette boucle et xAStr est le second mot clé de recherche sur cette seconde boucle.

Comment puis je les réunir pour que la recherche se fasse sur les différents onglets en recherchant ces deux mots ?

Sinon merci pour le bout de code que j'essaye tout de suite ...

Au plaisir,

Le 14/03/2022 à 10:25

Bonjour

1. Pourriez vous m'expliquer le pourquoi de ces lignes de code sachant que si je comprends xstr est la feuille LISTE. Vous supprimez la feuille Liste au départ de la macro ?

Set xCWs = ActiveWorkbook.Worksheets.Item(xStr)
If Not xCWs Is Nothing Then
    xCWs.Delete
End If
Set xCWs = ActiveWorkbook.Worksheets.Add
xCWs.Name = xStr
xC = 1

2. Les données Garde, AP, pupille etc... sont bien des valeurs dans la colonne S de chaque feuille du fichier ?
3. Les 4 premières variables nommées Liste et Aemo sont bien des feuilles ?

Avoir le fichier eu été un "must"

Edit : Essayez toujours ceci mais c'est un peu lourd. Je pense qu'il serai plus intéressant d'utiliser un boucle avec l'instruction FIND ...FINDNEXT

Public Sub CopyRows_Garde()
Dim xWs As Worksheet, xCWs As Worksheet
Dim xRg As Range, xRRg As Range
Dim xStrName As String, xRStr As String, xAStr As String, xMStr As String, xDStr As String, xPStr As String, xTStr As String, xCStr As String
Dim xStr As String, xJtr As String, xBtr As String, xCtr As String
Dim xC As Integer, i As Integer
Dim mot()

On Error Resume Next
'Application.DisplayAlerts = False
xStr = "LISTE"
xJtr = "LISTE AEMO"
xBtr = "AEMO, AEMO+TDC, AEMO-R"
xCtr = "LISTE ASE"

xRStr = "GARDE"
xAStr = "AP"
xPStr = "Pupille"
xMStr = "AP Mère/Enfant"
xDStr = "DAP"
xTStr = "Tutelle"
xCStr = ""

Set xCWs = ActiveWorkbook.Worksheets.Item(xStr)
If Not xCWs Is Nothing Then
    xCWs.Delete
End If
Set xCWs = ActiveWorkbook.Worksheets.Add
xCWs.Name = xStr
xC = 1

mot = Array("GARDE", "AP", "Pupille", "AP Mère/Enfant", "DAP", "Tutelle", """")

For Each xWs In ActiveWorkbook.Worksheets

    If xWs.Name <> "xStr" And xWs.Name <> "xJtr" And xWs.Name <> "xBtr" And xWs.Name <> "xCtr" Then
        For i = LBound(mot) To UBound(mot)
            Set xRg = xWs.Range("S:S")
            Set xRg = Intersect(xRg, xWs.UsedRange)
            For Each xRRg In xRg
                If xRRg.Value = mot(i) Then
                'If xRRg.Value = xRStr Then
                   xRRg.EntireRow.Copy
                   xCWs.Cells(xC, 1).PasteSpecial xlPasteValuesAndNumberFormats
                   xC = xC + 1
                End If
            Next xRRg
        Next i
    End If
Next xWs
'Application.DisplayAlerts = True
End Sub

si ok...

Le 23/03/2022 à 17:05

Merci, cela m'a aidé ...

J'ai reduit le temps d'execution de la macro

Rechercher des sujets similaires à "comment optimiser code"