How to optimize that code ?

[Grek]

Hello,

I've just wrote this code with my knowledge (basic) in excel and vba and some parts of code found on the internet.
It is working fine, however could you please help me to optimize that code ?

Thanks a lot,

Greg

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!"

 

[goldfish]

To start off a few notes. One: Don't use "On error resume next" unless nessasary. Your code might be erroring and you would never know! Errors are a good thing believe it or not... if you are going to use "On error resume next" you want to do something called Error handling, which will check if err has any value so the user knows if something didn't work properly. (Maybe you added it because Find might error if nothing comes back? I don't know, but my solution does not error if nothing is returned)

I tend to feel the same holds true for "DisplayAlerts" and "EnableEvents"... I don't turn them off unless I have a specific reason for it.

Two: Declare your variables. If something is going to be a integer than use "Dim varCount as Long" or as a decimal "Dim varValue as Double" or as a text, "Dim varName as String" or as a workbook, "Dim CurBook as Workbook"... etc. This will speed up the code. Use Option Explicit at the start of the module will force you to declare all your variables, which can help get you into this good habit.

Three: Don't use "Select" or "ActiveCell" or "Selection". This slows down your code, because it is much faster to just set the value of a cell than to select that cell and then set the value of the selected cell.

Anyway, here is some code... Your code was kind of long and complex, and I may have screwed a thing or two up, like which sheet is suppose to be selected when your for loop ends, or my xlDown might be off by a cell or two. But this should do the trick with perhaps a few minor adjustments. If anything with my code goes wrong try and see if its a simple, easy to figure out fix, but if not, don't hesitate to ask.

Sub ClientX()
Dim varMonth As String, varClientSheet As String
Dim wbCodeBook As Workbook, wbResults As Workbook
Dim My_Path As String, Cur_File_Name As String

varMonth = Range("J13").Value
varClientSheet = "Client X"
Set wbCodeBook = ThisWorkbook

Application.ScreenUpdating = False

My_Path = "T:\Operations\Files\Client X\" & varMonth & "\"
Cur_File_Name = Dir(My_Path & "*Email 1.xls", vbNormal) ' Retrieve the first entry.
Do While Cur_File_Name <> "" 'Starts loop through files
    Set wbResults = Workbooks.Open(Filename:=Cur_File_Name, UpdateLinks:=0)
    wbResults.Range("A5:Y30").Copy
    wbCodeBook.Sheets(varClientSheet).Range("F2").End(xlDown).Offset(-1).PasteSpecial _
        Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    wbResults.Close SaveChanges:=False
Loop

With Sheets(varClientSheet)
    .Range("A1").Value = Application.WorksheetFunction.Max(.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
End With

With Sheets("Menu").Cells.Find(What:="Client X", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False)
    .Offset(2, 3).Value = My_Path
    .Offset(1, 3).Value = Now()
End With

Application.ScreenUpdating = True

MsgBox "Done!"
End Sub

HTH,
~Gold Fish

 

[Grek]

I will try this tomorrow. Thx a lot!

 

[Grek]

Hello,

I have tried the code, however it stops on the line "Set wbResults = Workbooks.Open(Filename:=Cur_File_Name, UpdateLinks:=0)"
It seems that the macro doesn't find the files...
Those file are actually in sub-directories of the month directory (varMonth)
In my code the part ".SearchSubFolders = True" allows the macro to browse the sub directories.
Maybe that is what is missing in your code.
However it doesn't work either when I put my file directly in the month's directory...

Do you have an idea where the problem comes from ?

Thanks

Greg

 

[goldfish]

Made slight adjustment for subdirectories:

Sub ClientX()
Dim varMonth As String, varClientSheet As String
Dim wbCodeBook As Workbook, wbResults As Workbook
Dim My_Path As String, Cur_File_Name As String

varMonth = Range("J13").Value
varClientSheet = "Client X"
Set wbCodeBook = ThisWorkbook

Application.ScreenUpdating = False

Call CheckDir("T:\Operations\Files\Client X\" & varMonth & "\", varClientSheet)

With Sheets(varClientSheet)
    .Range("A1").Value = Application.WorksheetFunction.Max(.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
End With

With Sheets("Menu").Cells.Find(What:="Client X", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False)
    .Offset(2, 3).Value = My_Path
    .Offset(1, 3).Value = Now()
End With

Application.ScreenUpdating = True

MsgBox "Done!"
End Sub


Sub CheckDir(OldDirName As String, varClientSheet As String)
Dim NewDirNames As String
Dim DirArray() As String
Dim Count As Long

ReDim Preserve DirArray(Count) As String
NewDirNames = Dir(OldDirName, vbDirectory)
Do While NewDirNames <> ""
If GetAttr(OldDirName & NewDirNames) = vbDirectory And NewDirNames <> "." And NewDirNames <> ".." Then
    ReDim Preserve DirArray(Count) As String
    DirArray(Count) = OldDirName & NewDirNames
    Count = Count + 1
End If
NewDirNames = Dir()
Loop
For Count = 1 To UBound(DirArray) - 1
    Call ActionOnFolder(DirArray(Count), varClientSheet)
    Call CheckDir(DirArray(Count) & "\", varClientSheet)
Next Count
End Sub


Sub ActionOnFolder(My_Path As String, varClientSheet As String)
Dim wbCodeBook As worbook
Set wbCodeBook = ThisWorkbook
Cur_File_Name = Dir(My_Path & "*Email 1.xls", vbNormal) ' Retrieve the first entry.
Do While Cur_File_Name <> "" 'Starts loop through files
    With Workbooks.Open(Filename:=My_Path & Cur_File_Name, UpdateLinks:=0)
        .Range("A5:Y30").Copy
        wbCodeBook.Sheets(varClientSheet).Range("F2").End(xlDown).Offset(-1).PasteSpecial _
            Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        .Close SaveChanges:=False
    End With
Loop
End Sub

~Gold Fish