Looping through sub-folders in a parent directory - vba - excel

Question

I am looking to copy/paste data from workbooks within different sub-folders within a user selected directory.
To explain: Basically, I want to automate a process whereby I perform a copy/paste ritual from many workbooks into one Summary Workbook (from which the code is initiated).
I have allowed user input to select the parent directory in which the subfolders are contained.
I have reached the stage where the looping occurs, but the data is not being copied and pasted.
Can anyone see flaw in my code or why it is not working?
Your help will be greatly appreciated.
Sub AAA()
Dim FSO As Scripting.FileSystemObject
Dim FF As Scripting.Folder
Dim SubF As Scripting.Folder
Dim strFolderName As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = -1 Then
strFolderName = .SelectedItems(1)
Else
MsgBox ("Selection Cancelled")
Exit Sub
End If
End With
Set FSO = New Scripting.FileSystemObject
Set FF = FSO.GetFolder(strFolderName)
For Each SubF In FF.SubFolders
DoOneFolder SubF
Next SubF
End Sub
Sub DoOneFolder(FF As Scripting.Folder)
Dim F As Scripting.File
Dim SubF As Scripting.Folder
Dim WBc As Workbook
Dim shtWBc As Object
Set shtWBc = Sheets("QC Results")
Dim shtBatchwbk As Object
Dim lastrow As Long
Set shtBatchwbk = ThisWorkbook.Sheets("QC Results")
lastrow = shtBatchwbk.Range("A65536").End(xlUp).Row
For Each F In FF.Files
If (F.Name) Like "QC_results*" & ".xlsm" Then
Set WBc = Workbooks.Open(F)
' Copy QC results range into batch summary workbook
shtWBc.Range("A4:SA11").Copy shtBatchwbk.Range("A" & lastrow)
WBc.Close SaveChanges:=False
Debug.Print F.Name
End If
Next F
For Each SubF In FF.SubFolders
DoOneFolder SubF
Next SubF
End Sub

Answer 1

I believe your problem is here:
Sub DoOneFolder(FF As Scripting.Folder)
Dim F As Scripting.File
Dim SubF As Scripting.Folder
Dim WBc As Workbook
Dim shtWBc As Object
Set shtWBc = Sheets("QC Results")
Dim shtBatchwbk As Object
Dim lastrow As Long
Set shtBatchwbk = ThisWorkbook.Sheets("QC Results")
lastrow = shtBatchwbk.Range("A65536").End(xlUp).Row
Notice that shtWBc and shtBatchwbk are most likely assigned to the exact same worksheet object.
shtBatchwbk is assigned from ThisWorkbook, and unless you have other workbooks open/active at the time, then shtWBc is assigned from the ActiveWorkbook, which would be the same workbook, thus the exact same worksheet.
The resolution would seem to be:
For Each F In FF.Files
If (F.Name) Like "QC_results*" & ".xlsm" Then
Set WBc = Workbooks.Open(F)
Set shtWBc = WBc.Sheets("QC Results") '##### ASSIGN THIS WORKSHEET FROM THE NEWLY OPNEED WORKBOOk
'Get the last row:
lastrow = shtBatchwbk.Range("A65536").End(xlUp).Row
' Copy QC results range into batch summary workbook
shtWBc.Range("A4:SA11").Copy shtBatchwbk.Range("A" & lastrow)
WBc.Close SaveChanges:=False
Debug.Print F.Name
End If
Next F
Otherwise, revise your Q to provide more detail per Alexandre's comment.
UPDATE FROM COMMENTS
If you only need values, then this should be more reliable and faster than copy/paste.
Instead of:
shtWBc.Range("A4:SA11").Copy shtBatchwbk.Range("A" & lastrow)
Do this:
shtBatchwbk.Range("A" & lastrow).Resize( _
shtWBc.Range("A4:SA11").Rows.Count, _
shtWBc.Range("A4:SA11").Columns.Count).Value = shtWBc.Range("A4:SA11").Value
And if you also want to copy formatting without doing the full "copy" because it sometimes changes/transposes numbers, etc., then you can add this as well:
shtWBc.Range("A4:SA11").Copy
shtBatchwbk.Range("A" & lastrow).PasteSpecial xlPasteFormats