With Application.FileSearch how do I replace

D

ddavis5891

New Member
Joined
Apr 5, 2023
Messages
5
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
Hi everyone,

Moving with the times, haha I'm testing several macro excel files in Windows 10 which have been working in Windows 7. I've got some VBA code in one of my files which does not work in Windows 10. I was hoping for some assistance as to what i can replace Application.FileSearch? Very much appreciate any help here! My code is as follows -

VBA Code: 
Range("nrgCC_Start").Select
x = 0

Do Until ActiveCell.Offset(x, 0).Value = ""
    strCost_Centre = ActiveCell.Offset(x, 0).Value
    
    If strDivision <> ActiveCell.Offset(x - 1, 1).Value Then
        strReport_Date = Format(Range("nrgReport_Date").Value, "mmm-yy")
        strDivision = ActiveCell.Offset(x, 1).Value
        Workbooks.Open "c:\Cost Analysis\Cost Centre Template v1.4 - ND.xls", False, True, , "jkl"
    End If
    
    
    On Error GoTo 0
    Set wbCodeBook = ThisWorkbook
        With Application.FileSearch
            .NewSearch
            .LookIn = "c:\Cost Analysis\" & strReport_Date
            .FileType = msoFileTypeExcelWorkbooks
            .Filename = "Payroll Cost Analysis " & strCost_Centre & " " & strReport_Date & ".xls"
                If .Execute > 0 Then
                    For lCount = 1 To .FoundFiles.Count
                        Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)
                        ThisWorkbook.Activate
                        ActiveCell.Offset(x, 2).Value = "Copied"
                        Workbooks("Payroll Cost Analysis " & strCost_Centre & " " & strReport_Date & ".xls").Activate
                        Worksheets("Employee Breakdown").Select
                        
                        If Range("A4").Value <> "" Then
                            Range("nrgEmp_Whole").Copy
                            
                            lngCCRowCount = Range("nrgEmp_Whole").Rows.Count
                            
                        
                            Workbooks("Cost Centre Template v1.4 - ND.xls").Activate
                            Worksheets("Employee Breakdown").Select
                        
                            Range("A4").Select
                            Do Until ActiveCell.Value = ""
                                ActiveCell.Offset(1, 0).Select
                            Loop
                        
                            lngCCRowStart = ActiveCell.Row
                            
                            ActiveCell.PasteSpecial xlPasteAll
                            
                            lngCCLimit = lngCCRowStart + (lngCCRowCount - 1)
                            
                            For lngCCCurrentRow = lngCCRowStart To lngCCLimit
                              Worksheets("Employee Breakdown").Cells(lngCCCurrentRow, 7).Value = strCost_Centre
                            
                            Next lngCCCurrentRow

                            
                            
                        End If
 

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
Sort by date Sort by votes
This will open your file. You can copy the rest of the code in.
VBA Code: 
Sub OpenFile()
    Dim Path As String
    Dim FSO As FileSystemObject
    Dim Fl  As File
    Dim Fld As Folder
    Dim MatchFile As String
    

    Path = "c:\Cost Analysis\" & strReport_Date
    MatchFile = "Payroll Cost Analysis " & strCost_Centre & " " & strReport_Date & ".xls"
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Fld = oFSO.GetFolder(strPath)

    For Each Fl In Fld.Files
      If UCase(Fl.Name) Like UCase(MatchFile) Then
        Workbooks.Open (Fl.Path)
      End If
    Next Fl

    Set FSO = Nothing
    Set Fl = Nothing
    Set Fld = Nothing
End Sub
 
Upvote 0
Wow, thanks for the speedy reply! Excuse my ignorance but from what point in my original code am i replacing with your suggested code? Many thanks.
 
Upvote 0
Well looks like there is parts of your code missing but think this is it.
VBA Code: 
Sub OpenFile()
    Dim Path As String
    Dim FSO As FileSystemObject
    Dim Fl  As File
    Dim Fld As Folder
    Dim MatchFile As String
    

    Path = "c:\Cost Analysis\" & strReport_Date
    MatchFile = "Payroll Cost Analysis " & strCost_Centre & " " & strReport_Date & ".xls"
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Fld = oFSO.GetFolder(strPath)

    For Each Fl In Fld.Files
      If UCase(Fl.Name) Like UCase(MatchFile) Then
        Workbooks.Open (Fl.Path)
        ThisWorkbook.Activate
        ActiveCell.Offset(x, 2).Value = "Copied"
        Workbooks("Payroll Cost Analysis " & strCost_Centre & " " & strReport_Date & ".xls").Activate
        Worksheets("Employee Breakdown").Select
        
        If Range("A4").Value <> "" Then
            Range("nrgEmp_Whole").Copy
            
            lngCCRowCount = Range("nrgEmp_Whole").Rows.Count
            
        
            Workbooks("Cost Centre Template v1.4 - ND.xls").Activate
            Worksheets("Employee Breakdown").Select
        
            Range("A4").Select
            Do Until ActiveCell.Value = ""
                ActiveCell.Offset(1, 0).Select
            Loop
        
            lngCCRowStart = ActiveCell.Row
            
            ActiveCell.PasteSpecial xlPasteAll
            
            lngCCLimit = lngCCRowStart + (lngCCRowCount - 1)
            
            For lngCCCurrentRow = lngCCRowStart To lngCCLimit
              Worksheets("Employee Breakdown").Cells(lngCCCurrentRow, 7).Value = strCost_Centre
            
            Next lngCCCurrentRow
        End If
      End If
    Next Fl

    Set FSO = Nothing
    Set Fl = Nothing
    Set Fld = Nothing
End Sub
 
Upvote 0
Thanks again for the support!! I wasnt sure how relevant the rest of the code would be so only posted the bit around FileSearch. I've copied the whole code this time. Where should I incorporate your code now? Many thanks!

VBA Code: 
Sub Rollup_Reports()

Dim x As Double, strReport_Date As String, strCost_Centre As String
Dim lCount As Long
Dim wbResults As Workbook
Dim wbCodeBook As Workbook
Dim strDivision As String

Dim lngCCRowStart As Long
Dim lngCCRowCount As Long
Dim lngCCLimit As Long
Dim lngCCCurrentRow As Long


Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False



Range("nrgCC_Start").Select
x = 0

Do Until ActiveCell.Offset(x, 0).Value = ""
    strCost_Centre = ActiveCell.Offset(x, 0).Value
    
    If strDivision <> ActiveCell.Offset(x - 1, 1).Value Then
        strReport_Date = Format(Range("nrgReport_Date").Value, "mmm-yy")
        strDivision = ActiveCell.Offset(x, 1).Value

        Workbooks.Open "c:\Cost Analysis\Cost Centre Template v1.4 - ND.xls", False, True, , "jkl"
    End If
    
    
    

    On Error GoTo 0
    Set wbCodeBook = ThisWorkbook
        With Application.FileSearch
            .NewSearch
     
            .LookIn = "c:\Cost Analysis\" & strReport_Date
            .FileType = msoFileTypeExcelWorkbooks
     
            .Filename = "Payroll Cost Analysis " & strCost_Centre & " " & strReport_Date & ".xls"
                If .Execute > 0 Then
                    For lCount = 1 To .FoundFiles.Count
                    
                        Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)
                        ThisWorkbook.Activate
                        ActiveCell.Offset(x, 2).Value = "Copied"
                        
                        Workbooks("Payroll Cost Analysis " & strCost_Centre & " " & strReport_Date & ".xls").Activate
                        Worksheets("Employee Breakdown").Select
                        
                        If Range("A4").Value <> "" Then
                            Range("nrgEmp_Whole").Copy
                            
                            
                            lngCCRowCount = Range("nrgEmp_Whole").Rows.Count
                            
                        
                            Workbooks("Cost Centre Template v1.4 - ND.xls").Activate
                            Worksheets("Employee Breakdown").Select
                            
                            
                            Range("A4").Select
                            Do Until ActiveCell.Value = ""
                                ActiveCell.Offset(1, 0).Select
                            Loop
                            
                           
                            lngCCRowStart = ActiveCell.Row
                            
                            ActiveCell.PasteSpecial xlPasteAll
                            
                            lngCCLimit = lngCCRowStart + (lngCCRowCount - 1)
                            
                            For lngCCCurrentRow = lngCCRowStart To lngCCLimit
                              Worksheets("Employee Breakdown").Cells(lngCCCurrentRow, 7).Value = strCost_Centre
                            
                            Next lngCCCurrentRow

                            
                            
                        End If
                        
                        Workbooks("Payroll Cost Analysis " & strCost_Centre & " " & strReport_Date & ".xls").Activate
                        Worksheets("Overtime Payments").Select
                        
                        If Range("A4").Value <> "" Then
                            
                            Range("nrgOT_Whole").Copy
                            
                            Workbooks("Cost Centre Template v1.4 - ND.xls").Activate
                            Worksheets("Overtime Payments").Select
                            
                            
                            Range("A4").Select
                            Do Until ActiveCell.Value = ""
                                ActiveCell.Offset(1, 0).Select
                            Loop
                            
                            ActiveCell.PasteSpecial xlPasteAll
                        End If
                        
                        Workbooks("Payroll Cost Analysis " & strCost_Centre & " " & strReport_Date & ".xls").Activate
                        Worksheets("Changes").Select
                        
                        If Range("A4").Value <> "" Then
                            
                            Range("nrgChange_Whole").Copy
                            
                            Workbooks("Cost Centre Template v1.4 - ND.xls").Activate
                            Worksheets("Changes").Select
                            
                            
                            Range("A4").Select
                            Do Until ActiveCell.Value = ""
                                ActiveCell.Offset(1, 0).Select
                            Loop
                            
                            ActiveCell.PasteSpecial xlPasteAll
                        End If
                        wbResults.Close SaveChanges:=False
                    Next lCount
                End If
        End With
    
    ThisWorkbook.Activate
    
    x = x + 1
    If ActiveCell.Offset(x, 1).Value <> strDivision Then
        Workbooks("Cost Centre Template v1.4 - ND.xls").SaveAs "c:\Cost Analysis\" & strReport_Date & "\Payroll Cost Analysis " & ActiveCell.Offset(x - 1, 1).Value & " " & strReport_Date & ".xls", , "PCA" & strDivision & "!" & Month(strReport_Date)
        
    End If
Loop



On Error GoTo 0

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

MsgBox ("Code Complete")


End Sub
 
Upvote 0
I haven't tested this.

VBA Code: 
Sub Rollup_Reports()

Dim Path As String
Dim FSO As FileSystemObject
Dim Fl  As File
Dim Fld As Folder
Dim MatchFile As String

Dim x As Double, strReport_Date As String, strCost_Centre As String
Dim lCount As Long
Dim wbResults As Workbook
Dim wbCodeBook As Workbook
Dim strDivision As String

Dim lngCCRowStart As Long
Dim lngCCRowCount As Long
Dim lngCCLimit As Long
Dim lngCCCurrentRow As Long


Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

Range("nrgCC_Start").Select
x = 0

Do Until ActiveCell.Offset(x, 0).Value = ""
    strCost_Centre = ActiveCell.Offset(x, 0).Value
    
    If strDivision <> ActiveCell.Offset(x - 1, 1).Value Then
        strReport_Date = Format(Range("nrgReport_Date").Value, "mmm-yy")
        strDivision = ActiveCell.Offset(x, 1).Value

        Workbooks.Open "c:\Cost Analysis\Cost Centre Template v1.4 - ND.xls", False, True, , "jkl"
    End If
    
    On Error GoTo 0
    Set wbCodeBook = ThisWorkbook

    Path = "c:\Cost Analysis\" & strReport_Date
    MatchFile = "Payroll Cost Analysis " & strCost_Centre & " " & strReport_Date & ".xls"
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Fld = oFSO.GetFolder(strPath)

    For Each Fl In Fld.Files
      If UCase(Fl.Name) Like UCase(MatchFile) Then
        Set wbResults = Workbooks.Open(Fl.Path)
                    
        ThisWorkbook.Activate
        ActiveCell.Offset(x, 2).Value = "Copied"
        
        Workbooks("Payroll Cost Analysis " & strCost_Centre & " " & strReport_Date & ".xls").Activate
        Worksheets("Employee Breakdown").Select
        
        If Range("A4").Value <> "" Then
            Range("nrgEmp_Whole").Copy
            
            lngCCRowCount = Range("nrgEmp_Whole").Rows.Count
        
            Workbooks("Cost Centre Template v1.4 - ND.xls").Activate
            Worksheets("Employee Breakdown").Select
            
            
            Range("A4").Select
            Do Until ActiveCell.Value = ""
                ActiveCell.Offset(1, 0).Select
            Loop
          
            lngCCRowStart = ActiveCell.Row
            
            ActiveCell.PasteSpecial xlPasteAll
            
            lngCCLimit = lngCCRowStart + (lngCCRowCount - 1)
            
            For lngCCCurrentRow = lngCCRowStart To lngCCLimit
              Worksheets("Employee Breakdown").Cells(lngCCCurrentRow, 7).Value = strCost_Centre
            
            Next lngCCCurrentRow
            
        End If
        
        Workbooks("Payroll Cost Analysis " & strCost_Centre & " " & strReport_Date & ".xls").Activate
        Worksheets("Overtime Payments").Select
        
        If Range("A4").Value <> "" Then
            
            Range("nrgOT_Whole").Copy
            
            Workbooks("Cost Centre Template v1.4 - ND.xls").Activate
            Worksheets("Overtime Payments").Select
            
            
            Range("A4").Select
            Do Until ActiveCell.Value = ""
                ActiveCell.Offset(1, 0).Select
            Loop
            
            ActiveCell.PasteSpecial xlPasteAll
        End If
        
        Workbooks("Payroll Cost Analysis " & strCost_Centre & " " & strReport_Date & ".xls").Activate
        Worksheets("Changes").Select
        
        If Range("A4").Value <> "" Then
            
            Range("nrgChange_Whole").Copy
            
            Workbooks("Cost Centre Template v1.4 - ND.xls").Activate
            Worksheets("Changes").Select
            
            Range("A4").Select
            Do Until ActiveCell.Value = ""
                ActiveCell.Offset(1, 0).Select
            Loop
            
            ActiveCell.PasteSpecial xlPasteAll
        End If
        wbResults.Close SaveChanges:=False
      End If
    Next
    
    ThisWorkbook.Activate
    
    x = x + 1
    If ActiveCell.Offset(x, 1).Value <> strDivision Then
        Workbooks("Cost Centre Template v1.4 - ND.xls").SaveAs "c:\Cost Analysis\" & strReport_Date & "\Payroll Cost Analysis " & ActiveCell.Offset(x - 1, 1).Value & " " & strReport_Date & ".xls", , "PCA" & strDivision & "!" & Month(strReport_Date)
        
    End If
Loop

On Error GoTo 0

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

MsgBox ("Code Complete")

End Sub
 
Upvote 0
Thanks again for taking the time to look at this. Im getting a 'User-defined type not defined' pop up error when it hits the 3rd line of code - Dim FSO As FileSystemObject

Any other suggestions? Many thanks
 
Upvote 0
You need to go into the VBE's Tools, References and place a check mark beside Microsoft Scripting Run-time.
 
Upvote 0
nemmi69 said:
You need to go into the VBE's Tools, References and place a check mark beside Microsoft Scripting Run-time.
Click to expand...
Thanks, I've checked that box now. Are there any other references that should be checked? I've got another error pop up - 'Compile error: Variable not defined' which is highlighting the following line of code (in bold) - Set Fld = oFSO.GetFolder(strPath)
 
Upvote 0
You must log in or register to reply here.

Forum statistics

Threads
1,223,911
Messages
6,175,337
Members
452,637
Latest member
Ezio2866

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top