VBA to copy data from multiple workbooks into master sheet

[excel_vba_1]

Hello Everyone!

I have to copy data from 10+ workbooks and paste it into a master workbook.
All the workbooks are located in a folder on my desktop: C:\Users\xbv\Desktop\group1

All the workbooks contain a sheet named 'appendix B', I have to open each workbook, go to sheet 'appendix B’, select columns range C to F starting from row 6 to row ‘x'(the last row can vary in each workbook), cntrl+v (copy), and paste the data range into master worksheet. In the master worksheet, I paste the data in Columns A to D and continue pasting/appending the data as I copy data from more workbooks. Eventually, the master workbook has the data in columns A to D from every workbook in one sheet.

The columns range C to F and starting from row 6 always remains constant in all the sheets (appendix B ) of every workbook. Each workbook contains 7 sheets, but I am only interested in sheet ‘appendix B’

I have to repeat the same steps for 10-30 workbooks and continue pasting/appending the data into master sheet. So, I was wondering if someone could please help me to create a VBA code for this? I'm really new to VBA and would really appreciate your help!

Please let me know if you require any clarification.

Many thanks! =)

 

[GavinAdcock]

OK, I'm a novice, and reformulating that to work in my macro is probably beyond me. I started with the script at the first post which is working for me:

Sub MonthlyUpdate21()
Application.ScreenUpdating = False
Dim wkbDest As Workbook
Dim wkbSource As Workbook
Set wkbDest = ThisWorkbook
Dim LastRow As Long
Const strPath As String = "C:\Users\kg3158\OneDrive\2021 Input Files\"
ChDir strPath
strExtension = Dir("*.xlsx*")
Do While strExtension <> ""
Set wkbSource = Workbooks.Open(strPath & strExtension)
With wkbSource
LastRow = .Sheets("2021").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
.Sheets("2021").Range("A3:AK" & LastRow).Copy wkbDest.Sheets("2021").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
.Close savechanges:=False
End With
strExtension = Dir
Loop
Application.ScreenUpdating = True
End Sub

Can this be easily edited to move from a simple copy command to "copy, paste-values"? I tried but couldn't get the syntax right.

 

[mumps]

Try:

Sub MonthlyUpdate21()
    Application.ScreenUpdating = False
    Dim wsDest As Workbook, wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Dim LastRow As Long
    Const strPath As String = "C:\Users\kg3158\OneDrive\2021 Input Files\"
    ChDir strPath
    strExtension = Dir("*.xlsx*")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            LastRow = .Sheets("2021").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Sheets("2021").Range("A3:AK" & LastRow).Copy
            wkbDest.Sheets("2021").Cells(wkbDest.Sheets("2021").Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[aidan_77]

Give this a try. I tested it on some dummy workbooks and it worked properly.

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Const strPath As String = "C:\Users\xbv\Desktop\group1\"
    ChDir strPath
    strExtension = Dir("*.xls*")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            .Sheets("Appendix B").Range("C6:F" & .Sheets("Appendix B").Range("C" & Rows.Count).End(xlUp).Row).Copy wkbDest.Sheets("Master1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            .Sheets("Appendix C").Range("D6:Y" & .Sheets("Appendix C").Range("D" & Rows.Count).End(xlUp).Row).Copy wkbDest.Sheets("Master2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            .Sheets("Appendix D").Range("D5:I" & .Sheets("Appendix D").Range("D" & Rows.Count).End(xlUp).Row).Copy wkbDest.Sheets("Master3").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Hey Mumps, I am trying to run a similar code and I am still running into the Run time error 9 subscript out of range. I only changed sheet names and the path. Has anything changed with Excel 2019 that could cause this? The data from the detail sheet I need starts at B21 and ends at column BT but the number of rows is variable.

Sub CopyRange()
Application.ScreenUpdating = False
Dim wkbDest As Workbook
Dim wkbSource As Workbook
Set wkbDest = ThisWorkbook
Dim tgtsht As String
tgtsht = "Detail"
Dim LastRow As Long
Const strPath As String = "G:\GLOBALPRGM\STAFF\Testing\"
ChDir strPath
strExtension = Dir("*.xlsx*")
Do While strExtension <> ""
Set wkbSource = Workbooks.Open(strPath & strExtension)
With wkbSource
.Sheets("Detail").Range("C20:F" & .Sheets("Detail").Range("C" & Rows.Count).End(xlUp).Row).Copy wkbDest.Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
.Close savechanges:=False
End With
strExtension = Dir
Loop
Application.ScreenUpdating = True
End Sub

 

[mumps]

Which line of code is highlighted when you click "Debug"? Also, please use code tags when posting code. After pasting your code, highlight it by selecting it and then click the 'VBA' icon on the menu.

 

[aidan_77]

Which line of code is highlighted when you click "Debug"? Also, please use code tags when posting code. After pasting your code, highlight it by selecting it and then click the 'VBA' icon on the menu.

.sheets("Detail").Range..... throws the Runtime Error 9

 

[mumps]

If this version gives you the same error, make sure that the sheet "Detail" exists in the source workbook and that the sheet name is spelled correctly and that it doesn't have any leading or trailing spaces in the name.

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook, wkbSource As Workbook, LastRow As Long
    Set wkbDest = ThisWorkbook
    Const strPath As String = "G:\GLOBALPRGM\STAFF\Testing\"
    ChDir strPath
    strExtension = Dir("*.xlsx*")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        Sheets("Detail").Range("C20:F" & Range("C" & Rows.Count).End(xlUp).Row).Copy wkbDest.Sheets("Master").Cells(wkbDest.Sheets("Master").Rows.Count, "A").End(xlUp).Offset(1, 0)
        wkbSource.Close savechanges:=False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[aidan_77]

Still comes with the same error at the same line. I have quadruple checked all the syntax and accuracy of my labeling of the sheets at this point :/

 

[mumps]

Could use the XL2BB add-in (icon in the menu) to attach screenshots (not pictures) of the "Detail" and "Master" sheets? Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

 

[aidan_77]

Unfortunately all file sharing sites are blocked for work here... Also the XLB2BB add in does not behave properly due to security issues with the add in (they have everything under a tight lock here).

Mumps, would it be okay if I just used pictures (Obviously not preferred)

Testing1.xlsx and Testing2.xlsx are the only two files in the testing folder (the path works- no issues there) . Master.xlsx file is saved in a separate location and is the only one open when I run the Macro.

I have changed range to reflect the location of the data within the two sheets.

Once again as per this example. the number of rows my change but the data needed to be copied will always start at a consentient Cell (in the example B2).
I just need the data from B2-O? to be copied out and pasted/ appended to the master file- all on the same tab.

Sub CopyRange()
Application.ScreenUpdating = False
Dim wkbDest As Workbook, wkbSource As Workbook, lastrow As Long
Set wkbDest = ThisWorkbook
Const strPath As String = "G:\GLOBALPRGM\STAFF\Testing\"
ChDir strPath
strExtension = Dir("*.xlsx*")
Do While strExtension <> ""
Set wkbSource = Workbooks.Open(strPath & strExtension)
Sheets("Detail").Range("B2:O" & Range("B" & Rows.Count).End(xlUp).Row).Copy wkbDest.Sheets("Master").Cells(wkbDest.Sheets("Master").Rows.Count, "A").End(xlUp).Offset(1, 0)
wkbSource.Close savechanges:=False
strExtension = Dir
Loop
Application.ScreenUpdating = True
End Sub

 

[mumps]

You can try pictures but the problem is that I can't copy/paste the data into Excel. Make sure the picture includes the sheet name. Also, this line:

Sheets("Detail").Range("B2:O" & Range("B" & Rows.Count).End(xlUp).Row).Copy wkbDest.Sheets("Master").Cells(wkbDest.Sheets("Master").Rows.Count, "A").End(xlUp).Offset(1, 0)

should be:

Sheets("Detail").Range("B2:O" & Sheets("Detail").Range("B" & Rows.Count).End(xlUp).Row).Copy  wkbDest.Sheets("Master").Cells(wkbDest.Sheets("Master").Rows.Count, "A").End(xlUp).Offset(1, 0)

Please use code tags when posting your code so it looks like what I have just posted.