collect data from multiple files and sheets

[vikas_newports]

Hello
I would like to request that I have multiple excel files and I want to copy all data from every sheet of each file into one Excel File (on one sheet)
each file contains the different number of sheets and also blank cells in data.

I want to append them to only on Main sheet of Master Data workbook. VBA code is the preference for this task.

[cubangt]

The first thing you would want to do is create a loop to go thru each file.
Then a loop to go thru each sheet in each file.
Based on the provided files, can you update your Master data file with the expected results?

I believe it pretty straight forward in the sense that you are wanting to copy each sheet from east, west, north and south and just "append" each one to the Main sheet in the master.

Is this the expected results for the Main sheet? if not please upload a version with the expected results.
Attachment 738393

[vikas_newports]

Is this the expected results for the Main sheet? if not please upload a version with the expected results.
Attachment 738393

yes it is the expected result . and one change is that
from all workbooks their sheets copied into Master file with the same sheet name.
e,g from East workbook copy all sheets into Master Workbook (macro file) in Sheet1 and Sheet2 and so on
but the every sheet data append into the same sheet.
Expected result is attached in this post

[jindon]

For the files uploaded.
Assuming all the files(including "Master Data.xlsm") are in the same folder.

Sub test()
    Dim myDir As String, e, temp, x, i As Long
    Dim cn As Object, rs As Object
    myDir = ThisWorkbook.Path & "\"
    For Each e In Array("East", "North", "South", "West")
        If Dir(myDir & e & ".xlsx") <> "" Then temp = e: Exit For
    Next
    If temp = "" Then MsgBox "No matched files in """ & myDir & """": Exit Sub
    Application.ScreenUpdating = False
    Sheets("main").Cells(1).CurrentRegion.Offset(1).ClearContents
    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    With cn
        .Provider = "Microsoft.Ace.OLEDB.12.0"
        .Properties("Extended Properties") = "Excel 12.0;HRD=Yes"
        .Open myDir & temp & ".xlsx"
    End With
    For Each e In Array("East", "North", "South", "West")
        If Dir(myDir & e & ".xlsx") <> "" Then
            For i = 1 To 10
                x = ExecuteExcel4Macro("'" & myDir & "[" & e & ".xlsx]sheet" & i & "'!r1c1")
                If Not IsError(x) Then
                    rs.Open "Select * From `Sheet" & i & "$` In '" & myDir & e & ".xlsx" & _
                    "' 'Excel 12.0;''HDR=Yes;'''", cn, 3
                    Sheets("Main").Range("a" & Rows.Count).End(xlUp)(2).CopyFromRecordset rs
                    rs.Close
                End If
            Next
        End If
    Next
    Application.ScreenUpdating = True
    Set rs = Nothing: Set cn = Nothing
End Sub

[vikas_newports]

For the files uploaded.
Assuming all the files(including "Master Data.xlsm") are in the same folder.

Perfect as always
one change is that
from all workbooks their sheets copied into Master file with the same sheet name.
e,g from East workbook copy all sheets into Master Workbook (macro file) in Sheet1 and Sheet2 and so on
but the every sheet data append into the same sheet.
Expected result is attached in this post

[jindon]

Sub test()
    Dim myDir As String, e, temp, x, i As Long, ii As Long
    Dim cn As Object, rs As Object
    myDir = ThisWorkbook.Path & "\"
    For Each e In Array("East", "North", "South", "West")
        If Dir(myDir & e & ".xlsx") <> "" Then temp = e: Exit For
    Next
    If temp = "" Then MsgBox "No matched files in """ & myDir & """": Exit Sub
    Application.ScreenUpdating = False
    Sheets("main").Cells(1).CurrentRegion.Offset(1).ClearContents
    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    With cn
        .Provider = "Microsoft.Ace.OLEDB.12.0"
        .Properties("Extended Properties") = "Excel 12.0;HRD=Yes"
        .Open myDir & temp & ".xlsx"
    End With
    Sheets("main").Cells(1).CurrentRegion.Offset(1).ClearContents
    For Each e In Array("East", "North", "South", "West")
        If Dir(myDir & e & ".xlsx") <> "" Then
            For i = 1 To 10
                x = ExecuteExcel4Macro("'" & myDir & "[" & e & ".xlsx]sheet" & i & "'!r1c1")
                If Not IsError(x) Then
                    If Not Evaluate("isref('sheet" & i & "'!a1)") Then Sheets.Add(, Sheets(Sheets.Count)).Name = "Sheet" & i
                    With Sheets("sheet" & i)
                        .Cells(1).CurrentRegion.Offset(1).ClearContents
                        rs.Open "Select * From `Sheet" & i & "$` In '" & myDir & e & ".xlsx" & _
                                "' 'Excel 12.0;''HDR=Yes;'''", cn, 3
                        For ii = 0 To rs.Fields.Count - 1
                            .Cells(1, ii + 1) = rs.Fields(ii).Name
                        Next
                        With .Range("a" & Rows.Count).End(xlUp)(2)
                            .CopyFromRecordset rs
                            .Resize(rs.RecordCount).EntireRow.Copy Sheets("Main").Range("a" & Rows.Count).End(xlUp)(2)
                        End With
                        rs.Close
                    End With
                End If
            Next
        End If
    Next
    Application.ScreenUpdating = True
    Set rs = Nothing: Set cn = Nothing
End Sub

[vikas_newports]

Thanks but it is not working properly . not fetching all data . please refer to result file.

[jindon]

Change to

Sub test()
    Dim myDir As String, e, temp, x, i As Long, ii As Long
    Dim cn As Object, rs As Object, ws As Worksheet
    myDir = ThisWorkbook.Path & "\"
    For Each e In Array("East", "North", "South", "West")
        If Dir(myDir & e & ".xlsx") <> "" Then temp = e: Exit For
    Next
    For Each ws In Worksheets
        ws.Cells(1).CurrentRegion.Offset(1).ClearContents
    Next
    If temp = "" Then MsgBox "No matched files in """ & myDir & """": Exit Sub
    Application.ScreenUpdating = False
    Sheets("main").Cells(1).CurrentRegion.Offset(1).ClearContents
    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    With cn
        .Provider = "Microsoft.Ace.OLEDB.12.0"
        .Properties("Extended Properties") = "Excel 12.0;HRD=Yes"
        .Open myDir & temp & ".xlsx"
    End With
    Sheets("main").Cells(1).CurrentRegion.Offset(1).ClearContents
    For Each e In Array("East", "North", "South", "West")
        If Dir(myDir & e & ".xlsx") <> "" Then
            For i = 1 To 10
                x = ExecuteExcel4Macro("'" & myDir & "[" & e & ".xlsx]sheet" & i & "'!r1c1")
                If Not IsError(x) Then
                    If Not Evaluate("isref('sheet" & i & "'!a1)") Then Sheets.Add(, Sheets(Sheets.Count)).Name = "Sheet" & i
                    With Sheets("sheet" & i)
                        rs.Open "Select * From `Sheet" & i & "$` In '" & myDir & e & ".xlsx" & _
                                "' 'Excel 12.0;''HDR=Yes;'''", cn, 3
                        For ii = 0 To rs.Fields.Count - 1
                            .Cells(1, ii + 1) = rs.Fields(ii).Name
                        Next
                        With .Range("a" & Rows.Count).End(xlUp)(2)
                            .CopyFromRecordset rs
                            .Resize(rs.RecordCount).EntireRow.Copy Sheets("Main").Range("a" & Rows.Count).End(xlUp)(2)
                        End With
                        rs.Close
                    End With
                End If
            Next
        End If
    Next
    Application.ScreenUpdating = True
    Set rs = Nothing: Set cn = Nothing
End Sub

[vikas_newports]

Thanks Jindon