Comment optimiser ce code?

[Grek]

Bonjour,

J'ai bricolé un petite macro excel vba avec mes connaissances basiques en vba et qq bouts de codes trouvés sur le net.
Pourriez-vous me dire ce qui pourrait être optimisé dans ce code ?

Merci beaucoup,

Gregory

Sub ClientX()
 
varMonth = Range("J13").Value
varClientSheet = "Client X"
Set wbCodeBook = ThisWorkbook
varMacro = ActiveWorkbook.Name
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False
     
    On Error Resume Next
     
    With Application.FileSearch
        .NewSearch
        .LookIn = "T:\Operations\Files\Client X\" & varMonth & "\"
        .FileType = msoFileTypeExcelWorkbooks
        .Filename = "*Email 1.xls"
        .SearchSubFolders = True
         
        If .Execute > 0 Then 'Workbooks in folder
            For lCount = 1 To .FoundFiles.Count ' Loop through all.
                 'Open Workbook  and Set a Workbook  variable to it
                Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)
        
 
varFilePath = ActiveWorkbook.path
 
   Range("A5:Y30").Copy
  
    Windows(varMacro).Activate
    Sheets(varClientSheet).Select
        Range("F2").Select
        Do Until ActiveCell.Value = ""
        ActiveCell.Offset(1, 0).Activate
        Loop
        ActiveCell.Offset(0, -2).Activate
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
        
                        wbResults.Close SaveChanges:=False
                 
            Next lCount
        End If
    End With
     
    On Error GoTo 0
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    
         
    Cellules = ActiveSheet.Range("D:D")
    Range("A1").Value = Application.WorksheetFunction.Max(Cellules)
    
    Range("F2").Select
    Selection.CurrentRegion.Select
    Selection.Sort Key1:=Range("F2"), Order1:=xlAscending, Key2:=Range("D2") _
        , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
        :=xlSortNormal
         
 
 
Sheets("Menu").Select
Range("A1").Select
 
Cells.Find(What:="Client X", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False).Activate
        
ActiveCell.Offset(2, 3).Value = varFilePath
ActiveCell.Offset(0, 3).Select
ActiveCell.Offset(1, 0).Value = Now()
 
MsgBox "Done!"

 

[porcinet82]

Re : Comment optimiser ce code?

Salut,

Je viens de jeter un oeil, pas facile puisque je ne peux pas la tester, mais fait quelques modif tout de même :

Sub ClientX()
 
varMonth = Range("J13").Value
varClientSheet = "Client X"
Set wbCodeBook = ThisWorkbook
varMacro = ActiveWorkbook.Name
    
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
     
On Error Resume Next
With Application.FileSearch
    .NewSearch
    .LookIn = "T:\Operations\Files\Client X\" & varMonth & "\"
    .FileType = msoFileTypeExcelWorkbooks
    .Filename = "*Email 1.xls"
    .SearchSubFolders = True
         
    If .Execute > 0 Then 'Workbooks in folder
        For lCount = 1 To .FoundFiles.Count ' Loop through all.
            'Open Workbook  and Set a Workbook  variable to it
            Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)
            varFilePath = ActiveWorkbook.Path
            Range("A5:Y30").Copy
            Windows(varMacro).Activate
            Sheets(varClientSheet).Select
            Cells(Range("F65536").End(xlUp).Row + 1, 4).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            'ou
            'Cells(Range("F2").End(xlDown).Row + 1, 4).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            wbResults.Close SaveChanges:=False
        Next lCount
    End If
End With
     
On Error GoTo 0
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
    
Range("A1").Value = Application.WorksheetFunction.Max(ActiveSheet.Range("D:D"))
Range("F2").CurrentRegion.Sort Key1:=Range("F2"), Order1:=xlAscending, Key2:=Range("D2") _
    , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
    False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
    :=xlSortNormal
 
Application.Goto Sheets("Menu").Range("A1")
Cells.Find(What:="Client X", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
    xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
    , SearchFormat:=False).Activate
        
ActiveCell.Offset(2, 3).Value = 1
ActiveCell.Offset(1, 3).Value = Now()
MsgBox "Done!"
End Sub

Petite remarque en plus, j'ai eu la fleme de le faire, mais il faudrait que tu déclares tes variables quand meme... 😉

@+

 

[Grek]

Re : Comment optimiser ce code?

Merci pour ta reponse, je vais examiner ça en detail demain !