Sub CopyData()
Application.ScreenUpdating = False
Dim fso, oFolder, oSubfolder, oFile, queue As Collection, MyFolder As String
Dim wsDest As Worksheet, wkbSource As Workbook, lCol As Long, lRow As Long
Dim splt As Variant, FN As String, wbName As String, x As Long: x = 1
Set wsDest = ThisWorkbook.Sheets("Sheet1")
Set fso = CreateObject("Scripting.FileSystemObject")
Set queue = New Collection
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then
MsgBox "You did not select a folder."
Exit Sub
End If
MyFolder = .SelectedItems(1) & "\"
End With
queue.Add fso.GetFolder(MyFolder)
Do While queue.Count > 0
Set oFolder = queue(1)
queue.Remove 1
For Each oSubfolder In oFolder.SubFolders
queue.Add oSubfolder
Next oSubfolder
For Each oFile In oFolder.Files
'If Right(oFile, 3) Like "xl*" Then
If Right(oFile, 3) Like "ls*" Then
Set wkbSource = Workbooks.Open(oFile)
splt = Split(oFile, "\")
FN = splt(UBound(splt) - 1)
wbName = Split(wkbSource.Name, ".")(0)
If Not IsError(Evaluate("=ISREF('[" & oFile.Name & "]" & "StockList" & "'!$A$1)")) Then
If Sheets("StockList").Range("A25") <> "" Then
With Sheets("StockList")
If x = 1 Then
lCol = .Cells(1, Columns.Count).End(xlToLeft).Column
wsDest.Range("A1") = "NurseryName"
.Range("A1").Resize(, lCol).Copy
wsDest.Range("B1").PasteSpecial xlPasteValues
x = x + 1
lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
.Range("A25").Resize(lRow - 24, lCol).Copy
wsDest.Range("B2").PasteSpecial xlPasteValues
wsDest.Range("A2").Resize(lRow - 24) = FN & "-" & wbName
Else
lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
lCol = .Cells(25, Columns.Count).End(xlToLeft).Column
.Range("A25").Resize(lRow - 24, lCol).Copy
wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial xlPasteValues
wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Resize(lRow - 24) = FN & "-" & wbName
End If
End With
End If
End If
Application.DisplayAlerts = False
wkbSource.Close False
Application.DisplayAlerts = True
End If
Next oFile
Loop
'=================================
wsDest.Name = "2019A" & "-StockList"
' ActiveWorkbook.SaveAs FileName:=MyFolder & FN & "-" & "EntryLists", FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.SaveAs Filename:="2019A" & "-" & "EntryLists", FileFormat:=xlCSV, CreateBackup:=False
Rows("1:1").Select
Selection.AutoFilter
Rows("2:2").Select
ActiveWindow.FreezePanes = True
Application.ScreenUpdating = True
Application.ScreenUpdating = True
'=================================
End Sub
