VBA Checking Workbooks in all Subfolders

D

dhubz

New member
Joined
May 29, 2018
Messages
6
Reaction score
0
Points
0
Excel Version(s)
2016
Hi Everyone,

I'm looking for some VBA help. The below code essentially opens each file in the main folder and checks for data. It then returns any values it is supposed to, then adds it to the next row to make a list. This part works great. Now the problem is I am changing the file location. The files used to all be in one main folder, the main folder will now only have sub-folders, and the files will be inside the sub-folders. I know that I need to loop through the subfolders, but I have tried some loop coding, but I can't get it to function.
Thanks


Code: 
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:\MAINFOLDER_PATH" ' 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
 
Thanks for the link, but....

Hi Simon, Thanks for the reply. I see from the link you provided, what the code is doing. I am not good at writing code, I can generally read it and figure out what it is doing, and cut and paste from there. I've been trying to integrate the code I posted first into this one, but I'm not having much luck. I am assuming it has something to do with the workbook and path structure, and the fact the FSO is already directing that. I have tried removing and reworking different pieces, but no luck. Any pointers in the right direction would be greatly appreciated.

Code: 
[COLOR=#444444][FONT=&quot]Public Sub openWB()[/FONT][/COLOR]    Dim FSO As Object
    Dim folder As Object, subfolder As Object
    Dim wb As Object
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
[COLOR=#0000FF][FONT=inherit]    folderPath = "C:\Users\WYMAN\Desktop\testDel"[/FONT][/COLOR]
    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)
           [COLOR=#0000FF][FONT=inherit] 'Modify your workbook[/FONT][/COLOR]
            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)
                [COLOR=#0000FF][FONT=inherit]'Modify your workbook[/FONT][/COLOR]
                ActiveWorkbook.Close True
            End If
        Next
    Next
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
        .EnableEvents = True
        .AskToUpdateLinks = True
    End With [COLOR=#444444][FONT=&quot]End Sub[/FONT][/COLOR]
 
You must log in or register to reply here.
Back
Top