Run macro on all xls files that contain certain word

[wirescool]

Hello! I'd like to run a macro called "NoFeeAudit" on all xls files in a certain folder and subfolders that contain the word "Current" in the file name.

I'm fairly new to VBA, so I poked around online, and arrived at this:

Sub runMe()

    Dim objFSO As Object
        Dim objFolder As Object
        Dim objFile As Object
        Dim MyPath As String
        Dim wb As Workbook


    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
    End With


    MyPath = "...\Clients"


    Set objFSO = CreateObject("Scripting.FileSystemObject")


    'Get the folder object associated with the directory
    Set objFolder = objFSO.GetFolder(MyPath)


    'Loop through the Files
    For Each objFile In objFolder.Files
        If InStr(objFile.Name, "~") = 0 _
            And InStr(objFile.Name, "Current *") <> 0 And InStr(objFile.Name, ".xls") <> 0 Then
            Set wb = Workbooks.Open(objFile, 3)
            Application.Run "'" & wb.Name & "'!NoFeeAudit"
            wb.Close SaveChanges:=True
        End If
    Next


    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With


End Sub

When I run this, it looks like I'm getting stuck in an infinite loop. No errors/breaks, but no results, either.

Where did I go wrong?

Thanks in advance!

 

[mumps]

Maybe:

Sub runMe()
    Application.ScreenUpdating = False
    Dim objFSO As Object
    Dim objFolder As Object
    Dim objFile As Object
    Dim MyPath As String
    Dim wb As Workbook
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
    End With
    MyPath = "C:\Test\" ' change path to suit your needs
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    'Get the folder object associated with the directory
    Set objFolder = objFSO.GetFolder(MyPath)
    'Loop through the Files
    For Each objFile In objFolder.Files
        If InStr(objFile.Name, "Book") <> 0 And InStr(objFile.Name, ".xls") <> 0 Then
            Set wb = Workbooks.Open(objFile, 3)
            Application.Run "'" & wb.Name & "'!NoFeeAudit"
            wb.Close SaveChanges:=True
        End If
    Next
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With
    Application.ScreenUpdating = True
End Sub

Change the folder path as indicated in the code.

 

[wirescool]

Thanks, mumps!

I ran what you wrote on a test folder, containing about 10 client folders, and I came back with the error "Run-time error 1004: Cannot run the macro 'Current ClientName.xls!NoFeeAudit.' The macro may not be available in this workbook or all macros may be disabled." It did open the first client workbook, exactly what I needed per my NoFeeAudit macro, though!

Here's my NoFeeAudit, just in case it's needed:

Public Sub NoFeeAudit()

Dim assetSheet As Worksheet
Dim auditSheet As Worksheet
Dim nextRow As Long
Dim lastRow As Long
Dim thisRow As Long


' Get the sheet references


assetSheet = Sheets("P3,4 Detail")
Set auditSheet = Workbooks.Open("...\NF_List.xlsm").Sheets("Audit")


' Find the last row on the asset sheet and the next row on the audit sheet
lastRow = assetSheet.Cells(assetSheet.Rows.Count, "V").End(xlUp).Row
nextRow = auditSheet.Cells(auditSheet.Rows.Count, "V").End(xlUp).Row + 1


' Look at all rows in the asset sheet
For thisRow = 1 To lastRow
    ' Check if column I contains NF
    If assetSheet.Cells(thisRow, "I").Value = "NF" Then
        ' Copy the entire row to the audit sheet
        assetSheet.Cells(thisRow, "I").EntireRow.Copy
        auditSheet.Cells(nextRow, "A").PasteSpecial xlValues
        
        ' Move to the next row on the audit sheet
        nextRow = nextRow + 1
    End If
Next thisRow


End Sub

Do I have to add the module containing my NoFeeAudit code to every client file? I was honestly hoping to avoid that with this code, since I'll be working with about 275+ client folders once I get through testing. It's also possible for the number to change, in the case of a client termination, or a new client onboarding process.

 

[mumps]

Here is my understanding of what you are trying to do:
-You want to open all xls files in a certain folder and subfolders that contain the word "Current" in the file name.
-Each of these files has a sheet named "P3,4 Detail"
-Next you want to open a file named "NF_List.xlsm" which contains a sheet named "Audit"
-If any cell in column I in the "P3,4 Detail" sheet contains the value "NF", you want to copy only the values in those rows to the "Audit" sheet

In summary, you want to copy all the rows from sheet "P3,4 Detail" in each of the xls files that contain the word "Current" in their name to a sheet named "Audit" in a file named "NF_List.xlsm". Is this correct?

From which workbook are you running the macro?

 

[wirescool]

Yes, that's it! I need the values of all of the NF rows on the "Current ClientName.xls" workbooks, "P3,4 Detail" sheets, in a selected folder and subfolders to go to the NF_List Audit sheet.

I'm just running it from a blank workbook that I'm calling NF_Check.xlsm. It doesn't contain anything except for the code I've described.

My goal from there is to have Task Scheduler open up NF_Check, then run the process once weekly overnight. I have a Batch File and a VBScript File prepared for this - let me know if you need to see what I have in these.

 

[mumps]

Give this a try. You no longer need the "NoFeeAudit" macro.

Sub CopyRows()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Set wkbDest = Workbooks.Open("C:\Test\NF_List.xlsm") 'change folder path to suit your needs
    Dim ws As Worksheet
    Set ws = wkbDest.Sheets("Audit")
    Dim wkbSource As Workbook
    Dim LastRow As Long
    Const strPath As String = "C:\Test\" 'change folder path to suit your needs
    ChDir strPath
    strExtension = Dir(strPath & "*.xls")
    Application.DisplayAlerts = False
    Do While strExtension <> ""
        If InStr(strExtension, "Current") <> 0 Then
            Set wkbSource = Workbooks.Open(strPath & strExtension)
            With wkbSource
                LastRow = .Sheets("P3,4 Detail").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                .Sheets("P3,4 Detail").Range("I1:I" & LastRow).AutoFilter Field:=1, Criteria1:="NF"
                .Sheets("P3,4 Detail").Range("I2:I" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy
                ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                wkbSource.Close savechanges:=False
            End With
        End If
        strExtension = Dir
    Loop
    wkbDest.Close True
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Change the 2 folder paths in the code to suit your needs. The macro assumes that the source files are all in one folder. The "NF_List.xlsm" can be in a different folder or the same folder as the source files.

 

[wirescool]

I gave this a try after updating the file paths to testing folders. Excel just flashes once, then nothing.

The NF_List file doesn't show that it's been modified in the folder, either. Is this considering subfolders? Do I just need to wait up longer?

Thanks again for all of your help!

 

[mumps]

If the files are in multiple subfolders, the macro will have to be modified. If that is the case, what is the path to the subfolders? I tried it with sample files all in one folder and it worked perfectly.

 

[wirescool]

I wish I could, but that's not up to me! It's how the client folder system was set up long before I started working at my firm.

I'll try and illustrate how it works per client below. Let's pretend that I was a client household with the name "Ms. Wires Cool" and a selected client program called "SAMPLE."

C:\Clients 'Main folder containing 275+ Client folders
C:\Clients\CoolW SAMPLE 'My example client folder. The number of spaces between household name and client program is seemingly random per client

​

C:\Clients\CoolW SAMPLE\CoolW Admin SAMPLE
C:\Clients\CoolW SAMPLE\CoolW Agreements SAMPLE
C:\Clients\CoolW SAMPLE\CoolW Investment SAMPLE​

C:\Clients\CoolW SAMPLE\CoolW Investment SAMPLE\CoolW Previous Investments​

C:\Clients\CoolW SAMPLE\CoolW Investment SAMPLE\Current CoolW.xls 'Here's where my target files are located
​

There are plenty of other folders and files under the client household, this is just a quick illustration. Let me know if this helps?

 

[mumps]

Try these macros. I have used C:\Clients as the path to the main folder containing all the sub folders and C:\Test as the path to the "NF_List.xlsm" file. Change the paths as necessary. Run the 'RunMe' macro.

Dim srcWB As Workbook
Dim wkbDest As Workbook
Dim ws As Worksheet
Dim LastRow As Long

Sub RunMe()
    Application.ScreenUpdating = False
    Set wkbDest = Workbooks.Open("C:\Test\NF_List.xlsm") 'change folder path to suit your needs
    Set ws = wkbDest.Sheets("Audit")
    Dim FileSystem As Object
    Dim HostFolder As String
    HostFolder = "C:\Clients\"  'change path of main folder to suit your needs
    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    DoFolder FileSystem.GetFolder(HostFolder)
    wkbDest.Close True
    Application.ScreenUpdating = True
End Sub

Sub DoFolder(Folder)
    Application.ScreenUpdating = False
    Dim SubFolder
    For Each SubFolder In Folder.SubFolders
        DoFolder SubFolder
    Next
    Dim File
    Application.DisplayAlerts = False
    For Each File In Folder.Files
        If File.Name Like "*Current*.xls" Then
            Set srcWB = Workbooks.Open(Filename:=File)
            With ActiveWorkbook
                LastRow = .Sheets("P3,4 Detail").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                .Sheets("P3,4 Detail").Range("I1:I" & LastRow).AutoFilter Field:=1, Criteria1:="NF"
                .Sheets("P3,4 Detail").Range("I2:I" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy
                ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                ActiveWorkbook.Close savechanges:=False
            End With
        End If
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub