VBA Combine Code- Loop through function

Question

I have a blank master sheet(C:\path1\path2\overdue.xlsm) it has column headers and a macro button
-the data pulled from other workbooks will start in row 2
-the macro needs to open an excel file (C:\path1\path2\path3\project1.xlsx)
-check for 2 text criteria - -a "Y" (Static cell B7) - -an "OVERDUE" (Range of cells always starts B16) range of 4+ cells to check
-If it matches both criteria it will copy various cells from the worksheet
-it needs to paste the copied cells but transposed into the next available row on master sheet(C:\path\path\overdue.xlsm)
- -then closes the excel file without saving the changes (C:\path1\path2\path3\project1.xlsx)
- -it needs to loop this macro through all of the subfolders within (C:\path1\path2) , each project has its own folder, each folder has its own xlsx file along with other project files(this is why the xlsx files are all in different folders)

1st code- for file check I run this macro in a template that has header columns. The returned info starts populating on row 2. It generates a list based on other workbooks. This code opens each file within a specified folder, checks for certain criteria, then generates a list if the criteria is met. Then closes the file. This works well if all of the files are in the same folder.

Sub OVERDUEcheck()
Dim sPath As String, sName As String
Dim bk As Workbook      'opened from the folder
Dim src As Worksheet    'sheet to retrieve data from
Dim sh As Worksheet     'the sheet with the command button
Dim rw As Long          'the row to write to on sh
Dim lr As Long          'last row col A of src sheet
Dim i As Integer        'for looping rows to look at

Set sh = ActiveSheet ' I will record the value and workbook name
' in the activesheet when the macro runs

rw = 2 ' which row to write to in the activesheet
sPath = "C:\Box Sync\LocateRequests\" ' Path for file location
sName = Dir(sPath & "*.xls")

Do While sName <> "" 'Loop until filename is blank
Set bk = Workbooks.Open(sPath & sName)
Set src = bk.Worksheets(2)

With src
    If .Range("B7").Text = "Y" Then
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        For i = 16 To lr
            If .Cells(i, "B").Text = "OVERDUE" Then
                sh.Cells(rw, "A") = .Range("b5")
                sh.Cells(rw, "B") = .Range("b6")
                sh.Cells(rw, "C") = .Range("b10")
                sh.Cells(rw, "D") = .Range("b11")
                sh.Cells(rw, "E") = .Range("a" & i)
                sh.Cells(rw, "F") = .Range("B12")
                rw = rw + 1
            End If
        Next i
    End If
End With

bk.Close SaveChanges:=False
sName = Dir()

Loop ' loop until no more files

End Sub

This 2nd code is something I found with google, it is code for looping other functions through folders and subfolders.

Public Sub openWB()    Dim FSO As Object
Dim folder As Object, subfolder As Object
Dim wb As Object

Set FSO = CreateObject("Scripting.FileSystemObject")
folderPath = "C:\Users\WYMAN\Desktop\testDel"
Set folder = FSO.GetFolder(folderPath)

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

For Each wb In folder.Files
    If Right(wb.Name, 3) = "xls" Or Right(wb.Name, 4) = "xlsx" Or 
Right(wb.Name, 4) = "xlsm" Then
        Set masterWB = Workbooks.Open(wb)
        'Modify your workbook
        ActiveWorkbook.Close True
    End If
Next
For Each subfolder In folder.SubFolders
    For Each wb In subfolder.Files
        If Right(wb.Name, 3) = "xls" Or Right(wb.Name, 4) = "xlsx" Or 
Right(wb.Name, 4) = "xlsm" Then
            Set masterWB = Workbooks.Open(wb)
            'Modify your workbook
            ActiveWorkbook.Close True
        End If
    Next
Next
With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
    .EnableEvents = True
    .AskToUpdateLinks = True
End With End Sub

Thanks

you'll get a more helpful answer if you give a more clear and detailed description before above the code. currently it's a bit confusing — Marcucciboy2
I've revised my original post, hopefully it makes more sense now. — Dave H
Sorry that I wasn't clear - the revision would need to be of your first paragraph, because it's not easy to understand what you're looking for as an end result — Marcucciboy2

Latot Latot · Accepted Answer · 2018-07-20T13:22:34

i think there is best way, to avoid reconstruct your code, your first function, you can do it a function with the path as a param

Sub OVERDUEcheck(sPath As String)
Dim sName As String
Dim bk As Workbook      'opened from the folder
Dim src As Worksheet    'sheet to retrieve data from
Dim sh As Worksheet     'the sheet with the command button
Dim rw As Long          'the row to write to on sh
Dim lr As Long          'last row col A of src sheet
Dim i As Integer        'for looping rows to look at

Set sh = ActiveSheet ' I will record the value and workbook name
' in the activesheet when the macro runs

rw = 2 ' which row to write to in the activesheet
sName = Dir(sPath & "*.xls")

Do While sName <> "" 'Loop until filename is blank
Set bk = Workbooks.Open(sPath & sName)
Set src = bk.Worksheets(2)

With src
    If .Range("B7").Text = "Y" Then
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        For i = 16 To lr
            If .Cells(i, "B").Text = "OVERDUE" Then
                sh.Cells(rw, "A") = .Range("b5")
                sh.Cells(rw, "B") = .Range("b6")
                sh.Cells(rw, "C") = .Range("b10")
                sh.Cells(rw, "D") = .Range("b11")
                sh.Cells(rw, "E") = .Range("a" & i)
                sh.Cells(rw, "F") = .Range("B12")
                rw = rw + 1
            End If
        Next i
    End If
End With

bk.Close SaveChanges:=False
sName = Dir()

Loop ' loop until no more files

End Sub

then in your second code, send the subdirectories to every subpath:

Public Sub openWB()    Dim FSO As Object
Dim folder As Object, subfolder As Object
Dim wb As Object

Set FSO = CreateObject("Scripting.FileSystemObject")
folderPath = "C:\Users\WYMAN\Desktop\testDel"
Set folder = FSO.GetFolder(folderPath)

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

OVERDUEcheck(folderPath)

For Each subfolder In folder.SubFolders
    OVERDUEcheck(subfolder.name)
Next

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

There is time i don't use VBA, maybe a miss some detail, but that is the idea.

Make big functions can confuse a lot, so i think is better divide the code with an idea or concept, and call it instead a big one, and is easy to change/edit in future, will be more intuitive, even you can make a function for file, then a function for folders.

In this cases i recommend you instead use a sub, use a function, like return 0 if is fine, and 1 if not, and in the function use "On Error" for error handle, to know if something fails, record the folder and continues working.

Cya.

VBA Combine Code- Loop through function

1 Answers