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

Jeffman52

New Member
Joined
May 14, 2021
Messages
12
Office Version
  1. 2010
Platform
  1. Windows
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.

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
 

Marc L

Well-known Member
Joined
Apr 5, 2021
Messages
1,151
Office Version
  1. 2010
Platform
  1. Windows
A demonstration for starters :​
VBA Code:
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
 
Solution

Excel Facts

How to change case of text in Excel?
Use =UPPER() for upper case, =LOWER() for lower case, and =PROPER() for proper case. PROPER won't capitalize second c in Mccartney

Jeffman52

New Member
Joined
May 14, 2021
Messages
12
Office Version
  1. 2010
Platform
  1. Windows
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

New Member
Joined
May 14, 2021
Messages
12
Office Version
  1. 2010
Platform
  1. Windows
All tied out correctly. Thank you for your efforts!
 

Forum statistics

Threads
1,137,354
Messages
5,681,002
Members
419,948
Latest member
Sbakker1

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top