In the below code, I am combining a specifically named worksheet from multiple workbooks into a single worksheet (paste special values). However there will be times when the combined data will not fit on a single worksheet and I will get an error that the "copy and paste areas are not the same size".
Can someone help with the below VBA so that if the data does not fit, it opens a new worksheet within the combined workbook and continues combining from source workbooks to the new worksheet until complete. The loop should continue until there is no data left to combine. (fills one worksheet, opens new worksheet fills new worksheet, fills that one and opens another worksheet...etc etc until all data in the folder is combined.) At the end I would have a single workbook with the possibility of multiple tabs of data from combining from multiple workbooks.
As should be obvious I am way over my head with figuring this out and any help would be appreciated.
Can someone help with the below VBA so that if the data does not fit, it opens a new worksheet within the combined workbook and continues combining from source workbooks to the new worksheet until complete. The loop should continue until there is no data left to combine. (fills one worksheet, opens new worksheet fills new worksheet, fills that one and opens another worksheet...etc etc until all data in the folder is combined.) At the end I would have a single workbook with the possibility of multiple tabs of data from combining from multiple workbooks.
As should be obvious I am way over my head with figuring this out and any help would be appreciated.
VBA Code:
Sub CopySheetData()
Application.ScreenUpdating = False
Dim MyFolder As String, MyFile As String, wkbSource As Workbook, wsDest As Worksheet, x As Long, LastRow As Long
Set wsDest = ThisWorkbook.Sheets("Sheet1")
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
MyFile = Dir(MyFolder)
Do While MyFile <> ""
Set wkbSource = Workbooks.Open(Filename:=MyFolder & "\" & MyFile)
ActiveSheet.Name = "Mi24"
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
For x = 1 To 1
LastRow = ActiveSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
With wsDest
ActiveSheet.UsedRange.Copy
.Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
.Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(LastRow) = wkbSource.Name
Application.CutCopyMode = False
End With
Next x
MyFile = Dir
wkbSource.Close False
Loop
Application.ScreenUpdating = True
End Sub