VBA Combine Code- Loop through function - vba

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

Answer 1

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.