Merging same format table from several spreadsheets into one

[Jaffabfc]

Hi,

I have in a folder around 2-300 spreadsheets that i am wanting to merge into one.
They are all setup with the exact same titles but i am wanting to merge them all into one.

With an added column.
So at the moment cells B2:Q2 are all the exact same in every spreadsheet, i am wanting to merge them all but an added column (maybe A starting at A2) and calling it the name of the spreadsheet its been pulled from.

If this possible? ideally without a bit of SQL, but if it has to be then thats fine.

Thanks

 

[mumps]

Try this macro (untested). Change the folder path (in red) to suit your needs.

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, srcWB As Workbook, LastRow As Long
    Set desWS = ThisWorkbook.Sheets(1)
    Const strPath As String = "C:\Test\" 
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set srcWB = Workbooks.Open(strPath & strExtension)
        With srcWB.Sheets(1)
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Range("B2:Q" & LastRow).Copy desWS.Cells(desWS.Rows.Count, "B").End(xlUp).Offset(1, 0)
            desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(LastRow - 1) = srcWB.Name
        End With
        srcWB.Close savechanges:=False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[Jaffabfc]

Hi,
Thanks for this.
I created a brand new spreadsheet that was blank and put this macro in and ran it but nothing happened.

i changed the path as well.
guessing it may be wrong.

thanks though

 

[mumps]

What changes did you make to the path? Try stepping through the macro one line at a time by pressing the F8 key. As you do that see if any file is being opened when you get to this line of code:

Set srcWB = Workbooks.Open(strPath & strExtension)

 

[Jaffabfc]

i only changed the location of the folder as suggested in the original post.

no files are been opened, is it possible that it wont work if the files are not xls/xlsx as i have just realised they are all xlsb files

 

[Joe4]

i only changed the location of the folder as suggested in the original post.

no files are been opened, is it possible that it wont work if the files are not xls/xlsx as i have just realised they are all xlsb files

Then you will need to change this:

    strExtension = Dir(strPath & "*.xlsx")

to this:

    strExtension = Dir(strPath & "*.xlsb")

 

[Jaffabfc]

Changed that as suggested and still isnt doing anything, just doing the same result

 

[mumps]

Please post the exact full path.

 

[Jaffabfc]

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, srcWB As Workbook, LastRow As Long
    Set desWS = ThisWorkbook.Sheets(1)
    Const strPath As String = "C:\Users\carlbow\Desktop\Non Pickable"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsb")
    Do While strExtension <> ""
        Set srcWB = Workbooks.Open(strPath & strExtension)
        With srcWB.Sheets(1)
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Range("B2:Q" & LastRow).Copy desWS.Cells(desWS.Rows.Count, "B").End(xlUp).Offset(1, 0)
            desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(LastRow - 1) = srcWB.Name
        End With
        srcWB.Close savechanges:=False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[mumps]

Try inserting a back slash at the end of the path string.