VBA code to combine files

[dinesh shah]

Dear friends,
I have .xlsm files a,b,c and d in a folder.
In sheet 1 of each file, range a4 to i75 I have data. I want to copy this data from each file to a master file say x.xlsm one below the other. Please help me with VBA code to do the same. Thanks in advance for any kind of help.

 

[alansidman]

Here is an alternative way to do it without any coding.

 

[Fuji]

vba

Sub test()
    Dim myDir$, e, wsName$, s$, c As Range, n&
    Const r$ = "A4:I75"
    Set c = Range(r): n = c.Row   '<--- change to any number you want for first row of output.
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myDir = .SelectedItems(1) & "\"
    End With
    If myDir = "" Then Exit Sub
    Application.ScreenUpdating = False
    For Each e In Array("a.xlsm", "b.xlsm", "c.xlsm", "d.xlsm")
        If Dir(myDir & e) = e Then
            wsName = GetSheetName(myDir & e)
            s = "'" & myDir & "[" & e & "]" & wsName & "'!" & c(1).Address(0, 0)
            With ThisWorkbook.Sheets(1).Cells(n, 1).Resize(c.Rows.Count, c.Columns.Count)
                .Formula = Replace("=if(#<>"""",#,"""")", "#", s)
                .Columns(.Columns.Count + 1) = e
                .Value = .Value: n = n + .Rows.Count
            End With
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Function GetSheetName(fn As String) As String
    With CreateObject("DAO.DBEngine.120").workspaces(0).OpenDatabase(fn, True, True, "excel 12.0;HDR=No;")
        GetSheetName = Replace(.tabledefs(0).Name, "'", "")
        GetSheetName = Left$(GetSheetName, Len(GetSheetName) - 1)
        .Close
    End With
End Function

 

[dinesh shah]

vba

Sub test()
    Dim myDir$, e, wsName$, s$, c As Range, n&
    Const r$ = "A4:I75"
    Set c = Range(r): n = c.Row   '<--- change to any number you want for first row of output.
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myDir = .SelectedItems(1) & "\"
    End With
    If myDir = "" Then Exit Sub
    Application.ScreenUpdating = False
    For Each e In Array("a.xlsm", "b.xlsm", "c.xlsm", "d.xlsm")
        If Dir(myDir & e) = e Then
            wsName = GetSheetName(myDir & e)
            s = "'" & myDir & "[" & e & "]" & wsName & "'!" & c(1).Address(0, 0)
            With ThisWorkbook.Sheets(1).Cells(n, 1).Resize(c.Rows.Count, c.Columns.Count)
                .Formula = Replace("=if(#<>"""",#,"""")", "#", s)
                .Columns(.Columns.Count + 1) = e
                .Value = .Value: n = n + .Rows.Count
            End With
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Function GetSheetName(fn As String) As String
    With CreateObject("DAO.DBEngine.120").workspaces(0).OpenDatabase(fn, True, True, "excel 12.0;HDR=No;")
        GetSheetName = Replace(.tabledefs(0).Name, "'", "")
        GetSheetName = Left$(GetSheetName, Len(GetSheetName) - 1)
        .Close
    End With
End Function