Append multiple sheet form multiple workbooks into one master file

[davidmg1982]

Hi everyone, I have a folder with more than 100 files with different name of course, but the same amount of 5 spreadsheets with identical names and identical columns (quantity and name), Im looking for a solution to merge all those files into a single one with 5 spreadsheets containing all the information.

I have no doubt there must be a solution already posted, but I cant express this request on a simpler way and the solutions I found are not quite what I need, any help you can give me will be very appreciated.

 

[mumps]

Start by opening a new, blank workbook. In this new workbook, create 5 sheets with the names corresponding to those in the source files. In each of those 5 sheets, insert the headers (quantity and name) in row 1. Place this macro in a regular module in the new workbook. Change the folder path (in red) where you files are saved to suit you needs. Save the file as a macro-enabled file. Run the macro.

Sub AppendSheets()
    Application.ScreenUpdating = False
    Dim desWB As Workbook, srcWB As Workbook, ws As Worksheet
    Set desWB = ThisWorkbook
    Const strPath As String = "C:\Test\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set srcWB = Workbooks.Open(strPath & strExtension)
        For Each ws In Sheets
            With desWB.Sheets(ws.Name)
                ws.UsedRange.Offset(1).Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
            End With
        Next ws
        srcWB.Close False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[davidmg1982]

Start by opening a new, blank workbook. In this new workbook, create 5 sheets with the names corresponding to those in the source files. In each of those 5 sheets, insert the headers (quantity and name) in row 1. Place this macro in a regular module in the new workbook. Change the folder path (in red) where you files are saved to suit you needs. Save the file as a macro-enabled file. Run the macro.

Sub AppendSheets()
    Application.ScreenUpdating = False
    Dim desWB As Workbook, srcWB As Workbook, ws As Worksheet
    Set desWB = ThisWorkbook
    Const strPath As String = "C:\Test\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set srcWB = Workbooks.Open(strPath & strExtension)
        For Each ws In Sheets
            With desWB.Sheets(ws.Name)
                ws.UsedRange.Offset(1).Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
            End With
        Next ws
        srcWB.Close False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Works fantastic! If I had a plus is possible to add the file name as column a?

 

[mumps]

Place the headers in each sheet of the new workbook in B1 and C1 then try:

Sub AppendSheets()
    Application.ScreenUpdating = False
    Dim desWB As Workbook, srcWB As Workbook, ws As Worksheet, LastRow As Long
    Set desWB = ThisWorkbook
    Const strPath As String = "C:\Test\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set srcWB = Workbooks.Open(strPath & strExtension)
        For Each ws In Sheets
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            With desWB.Sheets(ws.Name)
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(LastRow - 1).Value = srcWB.Name
                ws.UsedRange.Offset(1).Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(1)
            End With
        Next ws
        srcWB.Close False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[davidmg1982]

Place the headers in each sheet of the new workbook in B1 and C1 then try:

Sub AppendSheets()
    Application.ScreenUpdating = False
    Dim desWB As Workbook, srcWB As Workbook, ws As Worksheet, LastRow As Long
    Set desWB = ThisWorkbook
    Const strPath As String = "C:\Test\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set srcWB = Workbooks.Open(strPath & strExtension)
        For Each ws In Sheets
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            With desWB.Sheets(ws.Name)
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(LastRow - 1).Value = srcWB.Name
                ws.UsedRange.Offset(1).Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(1)
            End With
        Next ws
        srcWB.Close False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Thanks, its giving me an error for .cells (Compile error: invalid or unqualified reference)

 

[mumps]

Try:

LastRow = .Range("A" & .Rows.Count).End(xlUp).Row

 

[davidmg1982]

Try:

LastRow = .Range("A" & [B].Rows[/B].Count).End(xlUp).Row

Its repeating the error message but for .Rows

 

[mumps]

It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of one of your source sheets.

 

[davidmg1982]

I tried, but the file is in my work computer and here I can install any add-ins, upload any type of files, and cant export files to my personal computer. How else can I help you?

 

[mumps]

Try simply copying all the data on one of your source sheets and pasting it here.