Exécution plus rapide d'une macro

Le 25/11/2021 à 20:52
Bonjour à tous,

J'aimerai savoir si il serait possible de rendre plus rapide l'exécution de cette macro.

Actuellement elle tourne aux alentours des 10s.

Merci d'avance.
Sub Test()

Dim BoEcran As Boolean, bobarre As Boolean, boevent As Boolean, bosaut As Boolean
Dim icalcul As Integer
Dim Plg
Dim wb As Workbook
Dim Lg%
Dim Cel As Range

If MsgBox("Veux-tu lancer la commande?", _
vbYesNo + vbInformation, "Import - Export") = 7 Then Exit Sub

BoEcran = Application.ScreenUpdating
bobarre = Application.DisplayStatusBar
icalcul = Application.Calculation
boevent = Application.EnableEvents
bosaut = ActiveSheet.DisplayPageBreaks

Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False

ThisWorkbook.Sheets("X").Unprotect Password:="MERCI"

ThisWorkbook.Sheets("X").Range("$A$3:$T$3").AutoFilter

Plg = ThisWorkbook.Sheets("X").Range("E4:F203")
ThisWorkbook.Sheets("X").Range("E4:F203") = Application.Trim(Plg)

Set wb = Workbooks.Open(ThisWorkbook.Path & "\R.xlsx")

wb.Sheets("A").Range("$C$1:$P$1").AutoFilter

    ThisWorkbook.Sheets("X").Range("D4:L203").Copy
    wb.Sheets("A").Range("D2:L201").PasteSpecial xlPasteValues
    ThisWorkbook.Sheets("X").Range("N4:O203").Copy
    wb.Sheets("A").Range("N2:O201").PasteSpecial xlPasteValues
    ThisWorkbook.Sheets("X").Range("F4:F203").Copy
    wb.Sheets("A").Range("C2:C201").PasteSpecial xlPasteValues
    ThisWorkbook.Sheets("X").Range("I4:I203").Copy
    wb.Sheets("A").Range("P2:P201").PasteSpecial xlPasteValues

wb.Sheets("A").Range("$C$1:$P$1").AutoFilter

With wb.Sheets("A")

    wb.Sheets("B").Range("A:Z").ClearContents
    wb.Sheets("A").Range("C1:P801").AutoFilter Field:=1, Criteria1:="<>", Operator:=xlAnd
    wb.Sheets("A").Range("C2:P801").SpecialCells(xlCellTypeVisible).Copy '[D2]
    wb.Sheets("B").Range("A2").PasteSpecial xlPasteValues

End With

wb.Worksheets("B").Activate

Lg = [A65536].End(xlUp).Row
    Application.ScreenUpdating = False
        For Each Cel In wb.Sheets("B").Range("A2:A" & Lg)
                Cel.Value = Cel.Value & "  " & Cel.Offset(0, 5)
        Next Cel

wb.Sheets("B").Range("A1") = "Fusion"

Derligne = Range("A" & Rows.Count).End(xlUp).Row
wb.Sheets("B").Sort.SortFields.Clear
    wb.Sheets("B").Sort.SortFields.Add Key:=Range("N2:N" & Derligne) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With wb.Sheets("B").Sort
        .SetRange Range("A2:N" & Derligne)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
listenoms = "/"
i = Range("A" & Rows.Count).End(xlUp).Row
Do While i > 1
If listenoms Like "*/" & Range("A" & i) & "/*" Then
If Range("A" & i).Interior.ColorIndex <> 6 Then
Rows("" & i & ":" & i & "").Delete
End If
Else
listenoms = listenoms & Range("A" & i) & "/"
End If
i = i - 1
Loop
Derligne = Range("A" & Rows.Count).End(xlUp).Row
wb.Sheets("B").Sort.SortFields.Clear
    wb.Sheets("B").Sort.SortFields.Add Key:=Range("N2:N" & Derligne) _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With Sheets("B").Sort
        .SetRange Range("A2:N" & Derligne)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

wb.Sheets("B").Range("B2:J201").Copy
ThisWorkbook.Sheets("X").Range("D4:L203").PasteSpecial xlPasteValues
wb.Sheets("B").Range("L2:M201").Copy
ThisWorkbook.Sheets("X").Range("N4:O203").PasteSpecial xlPasteValues

wb.Save
wb.Close

ThisWorkbook.Sheets("X").Protect Password:="MERCI"

ThisWorkbook.Sheets("X").Protect Password:="MERCI", UserinterfaceOnly:=True, AllowSorting:=True, AllowFiltering:=True
ThisWorkbook.Sheets("X").Range("$A$3:$T$3").AutoFilter

Application.ScreenUpdating = BoEcran
Application.DisplayStatusBar = bobarre
Application.Calculation = icalcul
Application.EnableEvents = boevent
ActiveSheet.DisplayPageBreaks = bosaut

End Sub
Le 26/11/2021 à 08:43

bonjour,

Tu peux déjà tester ça, pour le reste j'ai pas le temps pour le moment...

Sub Test()

Dim BoEcran As Boolean, bobarre As Boolean, boevent As Boolean, bosaut As Boolean
Dim icalcul As Integer
Dim Plg, Arr, i%
Dim wb As Workbook
Dim Lg%
Dim Cel As Range

If MsgBox("Veux-tu lancer la commande?", _
vbYesNo + vbInformation, "Import - Export") = 7 Then Exit Sub

BoEcran = Application.ScreenUpdating
bobarre = Application.DisplayStatusBar
icalcul = Application.Calculation
boevent = Application.EnableEvents
bosaut = ActiveSheet.DisplayPageBreaks

Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False

ThisWorkbook.Sheets("X").Unprotect Password:="MERCI"

ThisWorkbook.Sheets("X").Range("$A$3:$T$3").AutoFilter

Plg = ThisWorkbook.Sheets("X").Range("E4:F203")
ThisWorkbook.Sheets("X").Range("E4:F203") = Application.Trim(Plg)

Set wb = Workbooks.Open(ThisWorkbook.Path & "\R.xlsx")

wb.Sheets("A").Range("$C$1:$P$1").AutoFilter

Arr = ThisWorkbook.Sheets("X").Range("D4:L203").Value
    wb.Sheets("A").Range("D2:L201") = Arr
Arr = ThisWorkbook.Sheets("X").Range("N4:O203").Value
    wb.Sheets("A").Range("N2:O201") = Arr
Arr = ThisWorkbook.Sheets("X").Range("F4:F203")
    wb.Sheets("A").Range("C2:C201") = Arr
Arr = ThisWorkbook.Sheets("X").Range("I4:I203")
    wb.Sheets("A").Range("P2:P201") = Arr

wb.Sheets("A").Range("$C$1:$P$1").AutoFilter

With wb.Sheets("A")

    wb.Sheets("B").Range("A:Z").ClearContents
    wb.Sheets("A").Range("C1:P801").AutoFilter Field:=1, Criteria1:="<>", Operator:=xlAnd
    wb.Sheets("A").Range("C2:P801").SpecialCells(xlCellTypeVisible).Copy '[D2]
    wb.Sheets("B").Range("A2").PasteSpecial xlPasteValues

End With

wb.Worksheets("B").Activate

Lg = [A65536].End(xlUp).Row
    Application.ScreenUpdating = False
Arr = wb.Sheets("B").Range("A2:A" & Lg).Value
For i = 1 To UBound(Arr)
Arr(i, 1) = Arr(i, 1) & " " & Arr(i, 6)
wb.Sheets("B").Range("A2:A" & Lg) = Arr

wb.Sheets("B").Range("A1") = "Fusion"

Derligne = Range("A" & Rows.Count).End(xlUp).Row
wb.Sheets("B").Sort.SortFields.Clear
    wb.Sheets("B").Sort.SortFields.Add Key:=Range("N2:N" & Derligne) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With wb.Sheets("B").Sort
        .SetRange Range("A2:N" & Derligne)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
listenoms = "/"
i = Range("A" & Rows.Count).End(xlUp).Row
Do While i > 1
If listenoms Like "*/" & Range("A" & i) & "/*" Then
If Range("A" & i).Interior.ColorIndex <> 6 Then
Rows("" & i & ":" & i & "").Delete
End If
Else
listenoms = listenoms & Range("A" & i) & "/"
End If
i = i - 1
Loop
Derligne = Range("A" & Rows.Count).End(xlUp).Row
wb.Sheets("B").Sort.SortFields.Clear
    wb.Sheets("B").Sort.SortFields.Add Key:=Range("N2:N" & Derligne) _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With Sheets("B").Sort
        .SetRange Range("A2:N" & Derligne)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

Arr = wb.Sheets("B").Range("B2:J201")
ThisWorkbook.Sheets("X").Range("D4:L203") = Arr
Arr = wb.Sheets("B").Range("L2:M201")
ThisWorkbook.Sheets("X").Range("N4:O203") = Arr

wb.Save
wb.Close

ThisWorkbook.Sheets("X").Protect Password:="MERCI"

ThisWorkbook.Sheets("X").Protect Password:="MERCI", UserinterfaceOnly:=True, AllowSorting:=True, AllowFiltering:=True
ThisWorkbook.Sheets("X").Range("$A$3:$T$3").AutoFilter

Application.ScreenUpdating = BoEcran
Application.DisplayStatusBar = bobarre
Application.Calculation = icalcul
Application.EnableEvents = boevent
ActiveSheet.DisplayPageBreaks = bosaut

End Sub

A+

Le 26/11/2021 à 10:23

Bonjour Galopin,

Merci beaucoup de ta proposition.

En exécutant ton code j'ai une erreur d'exécution 9.

Saurais-tu me dire quoi faire pour résoudre le problème stp?

Merci encore.

capture1 capture
Le 26/11/2021 à 12:56

Désolé mais je t'ai vraiment fait ça entre 2 portes...

Une version un peu plus aboutie :

Sub Test()

Dim BoEcran As Boolean, bobarre As Boolean, boevent As Boolean, bosaut As Boolean
Dim icalcul As Integer
Dim Plg, Arr, ArF, i%
Dim wb As Workbook
Dim Lg%
Dim Cel As Range

If MsgBox("Veux-tu lancer la commande?", _
vbYesNo + vbInformation, "Import - Export") = 7 Then Exit Sub

BoEcran = Application.ScreenUpdating
bobarre = Application.DisplayStatusBar
icalcul = Application.Calculation
boevent = Application.EnableEvents
bosaut = ActiveSheet.DisplayPageBreaks

Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False

'ThisWorkbook.Sheets("X").Unprotect Password:="MERCI"
ThisWorkbook.Sheets("X").Protect Password:="MERCI", UserinterfaceOnly:=True, AllowSorting:=True, AllowFiltering:=True
ThisWorkbook.Sheets("X").Range("$A$3:$T$3").AutoFilter
Plg = ThisWorkbook.Sheets("X").Range("E4:F203")
ThisWorkbook.Sheets("X").Range("E4:F203") = Application.Trim(Plg)

Set wb = Workbooks.Open(ThisWorkbook.Path & "\R.xlsx")
With wb.Sheets("A")
   .Range("$C$1:$P$1").AutoFilter
      Arr = ThisWorkbook.Sheets("X").Range("D4:L203").Value
   .Range("D2:L201") = Arr
      Arr = ThisWorkbook.Sheets("X").Range("N4:O203").Value
   .Range("N2:O201") = Arr
      Arr = ThisWorkbook.Sheets("X").Range("F4:F203")
   .Range("C2:C201") = Arr
      Arr = ThisWorkbook.Sheets("X").Range("I4:I203")
   .Range("P2:P201") = Arr
   .Range("$C$1:$P$1").AutoFilter

      wb.Sheets("B").Range("A:Z").ClearContents
   .Range("C1:P801").AutoFilter Field:=1, Criteria1:="<>", Operator:=xlAnd
      Arr = .Range("C2:P801").SpecialCells(xlCellTypeVisible).Value
      wb.Sheets("B").Range("A2").Resize(UBound(Arr), UBound(Arr, 2)) = Arr
End With

With wb.Worksheets("B")
   .Activate
   Lg = .[A65536].End(xlUp).Row
   Arr = .Range("A2:A" & Lg).Value
   ArF = .Range("F2:F" & Lg).Value
   For i = 1 To UBound(Arr)
      Arr(i, 1) = Arr(i, 1) & " " & ArrF(i, 1)
   Next
   .Range("A2:A" & Lg) = Arr
   .Range("A1") = "Fusion"

Derligne = .Range("A" & .Rows.Count).End(xlUp).Row
   .Sort.SortFields.Clear
   .Sort.SortFields.Add Key:=.Range("N2:N" & Derligne) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With wb.Sheets("B").Sort
        .SetRange Range("A2:N" & Derligne)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
listenoms = "/"
i = .Range("A" & .Rows.Count).End(xlUp).Row
Do While i > 1
   If listenoms Like "*/" & .Range("A" & i) & "/*" Then
      If .Range("A" & i).Interior.ColorIndex <> 6 Then
         .Rows("" & i & ":" & i & "").Delete
      End If
   Else
      listenoms = listenoms & .Range("A" & i) & "/"
   End If
   i = i - 1
Loop
Derligne = .Range("A" & .Rows.Count).End(xlUp).Row
   .Sort.SortFields.Clear
    .Sort.SortFields.Add Key:=Range("N2:N" & Derligne) _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With Sheets("B").Sort
        .SetRange Range("A2:N" & Derligne)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

   Arr = .Range("B2:J201")
      ThisWorkbook.Sheets("X").Range("D4:L203") = Arr
   Arr = .Range("L2:M201")
      ThisWorkbook.Sheets("X").Range("N4:O203") = Arr
End With
wb.Save
wb.Close

'ThisWorkbook.Sheets("X").Protect Password:="MERCI"
'ThisWorkbook.Sheets("X").Protect Password:="MERCI", UserinterfaceOnly:=True, AllowSorting:=True, AllowFiltering:=True
ThisWorkbook.Sheets("X").Range("$A$3:$T$3").AutoFilter
Application.ScreenUpdating = BoEcran
Application.DisplayStatusBar = bobarre
Application.Calculation = icalcul
Application.EnableEvents = boevent
ActiveSheet.DisplayPageBreaks = bosaut
End Sub

L'avantage c'est que cette après midi je n'ai pas trop d'obligation donc je pourrai surement intervenir plus rapidement en cas de pb.

A+

Le 26/11/2021 à 16:23

Désolé mais je t'ai vraiment fait ça entre 2 portes...

Ca serait vraiment minable de ma part d'en vouloir à une personne qui me propose son aide.

Pour revenir à ton code, il fonctionne parfaitement (je pense la renommer par "nitro" ).

Merci beaucoup du temps consacré.

A+

Rechercher des sujets similaires à "execution rapide macro"