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!

 

[wirescool]

This is great, thank you!

I have updated to the below.

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
            'Update links to other workbooks
            Set srcWB = Workbooks.Open(Filename:=File, UpdateLinks:=3)
            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"
                'Breaks on below line if client doesn't have any No Fee assets
                .Sheets("P3,4 Detail").Range("I2:I" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy
                'Column A doesn't always contain values and they're not important in this case, but E does
                ws.Cells(ws.Rows.Count, "E").End(xlUp).Offset(1, -4).PasteSpecial xlPasteValues
                'Put current client file name in column A
                ws.Cells(ws.Rows.Count, "E").End(xlUp).Offset(0, -4).Value = srcWB.Name
                ActiveWorkbook.Close savechanges:=False
            End With
        End If
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

This ended up breaking when it found a client who didn't have any NF rows. Could I just slap

On Error Resume Next

somewhere in there, and be okay?

I added an additional line to add the client file name to the output, so I would be able to identify which clients were missing if I needed to. Is there a better way to do this than what I put here?

 

[mumps]

When you copy an entire row you must paste it into column A. Since the data in column A is not important, I've changed the macro to put the client file name in column A before the rows are copied and then it will paste the copied rows into column A. The macro will also ignore the sheet if a client doesn't have any NF rows. Give this a try:

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, UpdateLinks:=3)
            With ActiveWorkbook
                LastRow = .Sheets("P3,4 Detail").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                If WorksheetFunction.CountIf(.Sheets("P3,4 Detail").Range("I:I"), "NF") > 0 Then
                    .Sheets("P3,4 Detail").Range("A3:A" & LastRow) = srcWB.Name
                    .Sheets("P3,4 Detail").Range("I1:I" & LastRow).AutoFilter Field:=1, Criteria1:="NF"
                    .Sheets("P3,4 Detail").Range("I3:I" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy
                    ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                    ActiveWorkbook.Close savechanges:=False
                End If
            End With
        End If
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

 

[wirescool]

I'm running this on my sample clients, and got hung up on a file that didn't contain the "P3,4 Detail" page buried in one of the subfolders. For example, someone named a file "Current ClientName Notes.xls." But the files of interest definitely contain the page with that name!

Thanks again! I really appreciate your help on this!

 

[mumps]

This version checks to make sure the sheet exists. If it doesn't exist in any file, that file is skipped.

Sub DoFolder(Folder)
    Application.ScreenUpdating = False
    Dim wsSheet As Worksheet
    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, UpdateLinks:=3)
            With ActiveWorkbook
                On Error Resume Next
                Set wsSheet = .Sheets("P3,4 Detail")
                On Error GoTo 0
                If Not wsSheet Is Nothing Then
                    LastRow = .Sheets("P3,4 Detail").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                    If WorksheetFunction.CountIf(.Sheets("P3,4 Detail").Range("I:I"), "NF") > 0 Then
                        .Sheets("P3,4 Detail").Range("A3:A" & LastRow) = srcWB.Name
                        .Sheets("P3,4 Detail").Range("I1:I" & LastRow).AutoFilter Field:=1, Criteria1:="NF"
                        .Sheets("P3,4 Detail").Range("I3:I" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy
                        ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                        ActiveWorkbook.Close savechanges:=False
                    End If
                End If
            End With
        End If
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

 

[wirescool]

Got much further this time! I made it about halfway through the sampled clients for testing, and broke with the result "We can't do that to a merged cell" on the line:

.Sheets("P3,4 Detail").Range("I3:I" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy

The particular client sheet where the break occurred also has pictures overlapping some of the rows that would be copied. I don't want the pictures to be displayed on the results sheet.

 

[mumps]

Merged cells always cause havoc for Excel macros and they must be avoided at all cost. You have to make sure that you unmerge any merged cells in all the client sheets. The pictures shouldn't be copied.

 

[wirescool]

I'm right there with you - the merged cells shouldn't be in there per business procedures. Those other "Current" sheets shouldn't have been, either, but here we are!

In case anyone puts merged cells in, though, this seems to work:

Sub DoFolder(Folder)    Application.ScreenUpdating = False
    Dim wsSheet As Worksheet
    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, UpdateLinks:=3)
            With ActiveWorkbook
                On Error Resume Next
                Set wsSheet = .Sheets("P3,4 Detail")
                On Error GoTo 0
                If Not wsSheet Is Nothing Then
                    LastRow = .Sheets("P3,4 Detail").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                    If WorksheetFunction.CountIf(.Sheets("P3,4 Detail").Range("I:I"), "NF") > 0 Then
                        .Sheets("P3,4 Detail").Range("A3:A" & LastRow) = srcWB.Name
                        .Sheets("P3,4 Detail").Cells.MergeCells = False
                        .Sheets("P3,4 Detail").Range("I1:I" & LastRow).AutoFilter Field:=1, Criteria1:="NF"
                        .Sheets("P3,4 Detail").Range("I3:I" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy
                        ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                        ActiveWorkbook.Close savechanges:=False
                    End If
                End If
            End With
        End If
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

This made it all the way through my testing folder. Only finishing touches I can think of would be to close the source data worksheets. They were all open at the end, but I do see the

ActiveWorkbook.Close

That should have done it?

 

[mumps]

I've moved the 'ActiveWorkbook.Close' line of code. Try this version:

Sub DoFolder(Folder)
    Application.ScreenUpdating = False
    Dim wsSheet As Worksheet
    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, UpdateLinks:=3)
            With ActiveWorkbook
                On Error Resume Next
                Set wsSheet = .Sheets("P3,4 Detail")
                On Error GoTo 0
                If Not wsSheet Is Nothing Then
                    LastRow = .Sheets("P3,4 Detail").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                    If WorksheetFunction.CountIf(.Sheets("P3,4 Detail").Range("I:I"), "NF") > 0 Then
                        .Sheets("P3,4 Detail").Range("A3:A" & LastRow) = srcWB.Name
                        .Sheets("P3,4 Detail").Cells.MergeCells = False
                        .Sheets("P3,4 Detail").Range("I1:I" & LastRow).AutoFilter Field:=1, Criteria1:="NF"
                        .Sheets("P3,4 Detail").Range("I3:I" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy
                        ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                    End If
                End If
                ActiveWorkbook.Close savechanges:=False
            End With
        End If
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

 

[wirescool]

This passed testing on the sample clients that I was using.

Another business user tested this using different sample clients, and broke when a file was found that was password-protected. Is there any way to skip over these?

They also requested for the rows below the print area to not be included, as some client files show old rows below the print area. The print area is user-defined and varies per client, so I was thinking that maybe it could stop when Column C reads "Total Investment Assets" instead. The row number that this is in varies by client, as well. Not sure which way around would work best in a macro?

 

[mumps]

It is difficult to suggest a working code when there is no consistent format for entering data or organizing the data on the worksheet. I think that you have to inform the people using the macro that there are certain rules to be followed, for example: no merged cells, no old rows, no files missing the "P3,4 Detail" sheet, etc. If you don't do this, it is impossible to try to predict what other irregularities a user might have in his/her file so the macro will eventually not work or generate an error.