Combine but when Worksheet is full, start new worksheet in workbook

[Jeffman52]

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.

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

 

[Marc L]

A demonstration for starters :​

Sub Demo1()
     Dim P$, F$, Ws As Worksheet, L&, R&
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Please select the source folder"
     If .Show Then P = .SelectedItems(1) & "\" Else Exit Sub
    End With
        F = Dir(P):            If F = "" Then Beep: Exit Sub
        Set Ws = Sheet1
        L = Ws.Cells(Ws.Rows.Count, 2).End(xlUp).Row
        Application.ScreenUpdating = False
    Do
        With Workbooks.Open(P & F).Sheets("Mi24").UsedRange.Rows
            If Ws.Rows.Count - L < .Count Then Set Ws = Ws.Parent.Sheets.Add(, Ws): L = 0
            R = L + 1
            L = L + .Count
            Ws.Cells(R, 2).Resize(.Count, .Columns.Count).Value = .Value
           .Parent.Parent.Close False
        End With
               Ws.Range("A" & R & ":A" & L).Value2 = F
               F = Dir
    Loop Until F = ""
        Application.ScreenUpdating = True
        Set Ws = Nothing
End Sub

 

[Jeffman52]

A demonstration for starters :​

Hi Marc,
First thanks for being patient with me as you asked all your questions and tried to figure out my answers. I did a quick test and your VBA does seem to be doing exactly what I need. I have to tie out the data to be sure, but I do want to thank you for your efforts. As soon as I verify this works I will mark this as complete and answered. ?

 

[Jeffman52]

All tied out correctly. Thank you for your efforts!