Extracting Data from several Excel files in a folder and adding them in a active Table in a master worksheet

user_15645231 0
Viewed 155

In order to create a dynamic Dashboard I need to compile different file with different sheets in a main workbook. I manage to find a code to extract the files content and copying it into the main workbook.

Problem: the data gets copied, no problem but if I add a table in my main workbook the data get copied until the row "139" and then get copied 1 row after the end of the table.

Sub DIRECT()

Dim fName As String, fPath As String, fPathDone As String
Dim LR As Long, NR As Long
Dim wbData As Workbook, wsMaster As Worksheet, ws As Worksheet
Dim tbl As ListObject

Set wsMaster = ThisWorkbook.Sheets("Master-DIRECT") 
With wsMaster   
NR = 2
   fPath = "xxxxx" 
   fName = Dir(fPath & "*.xls*")

    Do While Len(fName) > 0

        If fName <> ThisWorkbook.Name Then 

            Set wbData = Workbooks.Open(fPath & fName) 

                            For Each ws In wbData.Worksheet

                                If ws.Name = "Direct" Then

                                   LR = ws.Range("A" & Rows.Count).End(xlUp).Row 
                                   ws.Range("A2:A" & LR).EntireRow.Copy .Range("A" & NR)  
                                   NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1            

                                End If

                             Next ws
                           fName = Dir 
        End If
    Loop
End With

Here is what happening for example

I would like to now if I am misunderstanding something in this code.

Thank you for taking time to read my question.

PS: I know about Power Query, I am trying to find an alternative solution

vba excel
1 Answers

Copy to Master Worksheet

  • Adjust the values in the constants section.
  • s - source (many, read from), d - destination (one - master, written to)
Option Explicit

Sub copyToMaster()

    Const sPath As String = "xxxxx" ' don't forget the '\'
    Const sPattern As String = "*.xls*"
    
    Set dws = ThisWorkbook.Worksheets("Master-DIRECT")
    Dim dCell As Range: Set dCell = dws.Range("A2")

    Dim sName As String: sName = Dir(sPath & sPattern)
    
    Dim swb As Workbook
    Dim sws As Worksheet
    Dim srg As Range
    Dim sLast As Long
    
    Application.ScreenUpdating = False
      
    Do While Len(sName) > 0
        If sName <> ThisWorkbook.Name Then
            Set swb = Workbooks.Open(sPath & sName)
            On Error Resume Next
            Set sws = swb.Worksheets("Direct")
            On Error GoTo 0
            If Not sws Is Nothing Then
                sLast = sws.Range("A" & sws.Rows.Count).End(xlUp).Row
                Set srg = sws.Range("A2:A" & sLast).EntireRow
                srg.Copy dCell
                Set dCell = dCell.Offset(srg.Rows.Count)
                Set sws = Nothing
            End If
            Application.DisplayAlerts = False
            swb.Close SaveChanges:=False
            Application.DisplayAlerts = True
        End If
        sName = Dir
    Loop
    'dwb.Save
    
    Application.ScreenUpdating = True
    
End Sub
user_98140690
Related