I have a VBA script that works fine for my needs, but of course, I was just provided with one more piece of criteria, and I have no clue how to make this revision. Okay, my current code is below, bear in mind I am still very new at VBA. I need this current code to be modified, so that in addition to looping through the folder selected and capturing all Excel files into a summary that it does the same for ANY sub folder within the folder. So the user would select the "top level" folder, and then all sub folder and their excel contents would be summarized. help! Thanks so much!
Sub GetData_Audit_Data()
Dim wbSrc As Workbook, wbTgt As Workbook
Dim wsSrc As Worksheet, wsTgt As Worksheet, ws As Worksheet
Dim stPath As String, stFile As String
Dim NumIndRows As Long
Dim j As Long
Dim i As Integer
Dim R As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
' Name of the tab data is to be copied into
Set wbTgt = ThisWorkbook
Set wsTgt = wbTgt.Worksheets("Audits")
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choose folder containing source data files"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then Exit Sub
stPath = .SelectedItems(1)
End With
stFile = Dir(stPath & "\")
'find where to start pasting data
R = 3
Do Until wsTgt.Cells(R, 1) = ""
R = R + 1
Loop
R = R - 1
While stFile <> ""
Set wbSrc = Workbooks.Open(stPath & "\" & stFile, False, True)
Application.StatusBar = wbSrc.Name
On Error Resume Next
Set wsSrc = wbSrc.Worksheets("Results Log")
If Err.Number > 0 Then 'Results Log sheet doesn't exist
Set wsSrc = wbSrc.Worksheets("Results Log")
Err.Clear
End If
On Error GoTo 0
With wsSrc
If Not wsSrc Is Nothing Then
.Activate
NumIndRows = .UsedRange.Rows.Count
For j = 3 To NumIndRows
If .Cells(j, 1) <> "" Then
R = R + 1
'copy columns A-HL
.Range(Cells(j, 1), Cells(j, 220)).Copy
wsTgt.Cells(R, 1).PasteSpecial Paste:=xlPasteValues
'write out time stamp in column HM
wsTgt.Cells(R, 221) = Now
'write out IND file name in column HN
wsTgt.Cells(R, 222) = wbSrc.Name
End If
Next j
End If
End With
wbSrc.Close (False)
Set wsSrc = Nothing
stFile = Dir
Wend
With Application
.ScreenUpdating = True
.StatusBar = False
.Calculation = xlCalculationManual
Application.DisplayAlerts = True
End With
MsgBox "Data transferred from all files in " & stPath, vbInformation + vbOKOnly
End Sub
Bookmarks