VBA Help

[Rahim Amir Ali]

I am trying to loop a macro through all sub folders. I've tried numerous things, I have code that works as long as the files are all within the same folder.

-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 project1.xlsx
-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 project 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)

I have tried mutliple variations of looping code and recording macros and piecing them together with other code that works but no luck.

Here is the code that works

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\!LOCATES TRACKING\FOR TRACKING\" ' 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

 

[Hui]

Rahim

Firstly, Welcome to the Chandoo.org Forums

Your post has been cross-posted, which means it has been seen on other websites. This is considered poor practice, as it can waste peoples time, which could be spent elsewhere, especially if you get a solution and don't notify us.

I encourage you to please read the site rules at:
http://forum.chandoo.org/link-forums/new-users-please-read.17/