Copying tables from multiple worksheets into one table VBA

Question

I want to code a macro that searches through multiple .xls* files and copies the tables into one big table in my masterfile. Currently the macro is able to access the different files and can copy the information. Now I want it to paste it into one table in my masterfile but i dont know how to make it paste the information from one table at the end of another without knowing how big each table is, so there is no overlapping or empty lines.

Sub New_Data()

Dim wb As Workbook
Dim ws As Worksheet
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog

'Deletes all current data in the masterfile 

Application.DisplayAlerts = False

   For Each ws In Worksheets
      If ws.Name = "Overview" Then ws.Range(A2, AT10000).ClearContents


   Application.DisplayAlerts = True

    
'User can pick what folder he wants to get his data from

     Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

     With FldrPicker
         .Title = "Please pick a Folder"
         .AllowMultiSelect = False
            If .Show <> -1 Then GoTo NextCode
            myPath = .SelectedItems(1) & "\"
     End With
    
'If invalid path is put in

     NextCode:
         myPath = myPath
         If myPath = "" Then GoTo ResetSettings

'All data ending on .xls* gets picked

     myExtension = "*.xls*"

'Declares the files as combination of path and .xsl*

     myFile = Dir(myPath & myExtension)


'Loop that actually opens up the files and picks the data from it

     Do While myFile <> ""

           Set wb = Workbooks.Open(Filename:=myPath & myFile)
   
           DoEvents
    
'Actual Process of copying, as you can see im totally lost

           For Each ws In Worksheets
             If ws.Name = "Übersicht" Then ws.Range("B6:BT10000").Copy
             Before ThisSheet.Range("A2:AT64").Paste
         
         
         wb.Close SaveChanges:=False
      
         DoEvents

         myFile = Dir
  Loop

'Feedback, for the code is done
  MsgBox "Done!"


End Sub

The problem is that I need to copy a varying amount of cells and have absolutly no clue how to achive that, any help (preferably explained simple, I'm quite new to VBA) will be appreciated, thanks a lot in advance.

user_14880578 · Answer

Some things to note:

There are numerous ways to find the last row and last column of a worksheet. Depending on what you are looking for, you will want to use different methods
Dir returns a string representing the name of a file, directory, or archive that matches a specified pattern. When we say fileName = Dir we are setting fileName equal to the next file which meets the pattern we set about

Good Luck!

Option Explicit

Sub Consolidate_Data()

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim sendRow As Long: sendRow = 2
    Dim src As Worksheet
    
    ' Create a worksheet object to reference the 'master' sheet
    Set ws = ThisWorkbook.Worksheets("Overview")
    lastRow = ws.UsedRange.SpecialCells(xlCellTypeLastCell).Row ' gets the lowest row where data is found
    lastCol = ws.UsedRange.SpecialCells(xlCellTypeLastCell).Column ' gets the rightmost column where data is found
    
    ' Clear Contents of ws (excluding header row that im assuming you have)
    ws.Range(ws.Cells(2, 1), ws.Cells(lastRow, lastCol)).ClearContents
    
    ' common directory where files are located
    Dim commonDirectory As String: commonDirectory = "C:\Desktop\Test_Folder\"
    Dim key As String: key = "*.xls" ' As you seemed to already understand the * denotes any length of any characters
    Dim fileName As Variant: fileName = Dir(commonDirectory & key)
    
    ' iterate through all files which follow the commonDirectory & key pattern
    While fileName <> ""
        ' opening workbooks is very slow, if you have a way to verify which workbooks you want to open based on the workbook name
        ' you could reduce runtime by quite a bit
        Set wb = Workbooks.Open(commonDirectory & fileName, , True) ' open the .xls workbook as read only
        
        ' check if the workbook contains "Ubersicht" (my keyboard doesnt like the accent on the U)
        For Each src In wb.Worksheets
            If src.name = "Ubersicht" Then
                ' COPY THE DATA
                lastRow = src.UsedRange.SpecialCells(xlCellTypeLastCell).Row ' gets the lowest row where data is found (in src -> aka your Ubersicht sheet)
                lastCol = src.UsedRange.SpecialCells(xlCellTypeLastCell).Column ' gets the rightmost column where data is found (in src -> aka your Ubersicht sheet)
                src.Range(src.Cells(1, 1), src.Cells(lastRow, lastCol)).Copy Destination:=ws.Range(ws.Cells(sendRow, 1), ws.Cells(sendRow, 1))
                sendRow = sendRow + lastRow
                Exit For
            End If
        Next
        
        wb.Close savechanges:=False
        fileName = Dir
    Wend

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub

Copying tables from multiple worksheets into one table VBA

1 Answers