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! =)

 

[mumps]

Try this macro. It assumes the destination sheet name in your destination workbook is called "Master". Change the name in the code to suit your needs.

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Dim LastRow As Long
    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
            LastRow = .Sheets("appendix B").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Sheets("appendix B").Range("C6:F" & LastRow).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

 

[excel_vba_1]

Try this macro. It assumes the destination sheet name in your destination workbook is called "Master". Change the name in the code to suit your needs.

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Dim LastRow As Long
    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
            LastRow = .Sheets("appendix B").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Sheets("appendix B").Range("C6:F" & LastRow).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

Thank you so much mumps!

When i run the code, i am getting an error on this line (highlighted yellow):

Set wkbSource = Workbooks.Open(strPath & strExtension)

The error says C:\Users\xbv\Desktop\group1\workbook1.xlsx could not be found. Check the spelling of the file name, and verify that the file location is correct.

I created the Master worksheet on desktop, could that might be the reason?

 

[mumps]

I had an extra space in one of the lines. Try:

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Dim LastRow As Long
    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
            LastRow = .Sheets("appendix B").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Sheets("appendix B").Range("C6:F" & LastRow).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

 

[excel_vba_1]

I had an extra space in one of the lines. Try:

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Dim LastRow As Long
    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
            LastRow = .Sheets("appendix B").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Sheets("appendix B").Range("C6:F" & LastRow).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

Hi Mumps,

I am still getting the same error on the same line:

Set wkbSource = Workbooks.Open(strPath & strExtension)

Please suggest. Thank you soo much for helping me.

 

[excel_vba_1]

Hi Mumps,

I am still getting the same error on the same line:

Set wkbSource = Workbooks.Open(strPath & strExtension)

Please suggest. Thank you soo much for helping me.

Hi Mumps,

The code works perfectly fine! I just had to had "\" to the path of the folder.


Thank you soooo much!! really appreciate it =)

 

[mumps]

My pleasure.

 

[excel_vba_1]

My pleasure.

Hi Mumps,

I was wondering if this would be possible:


Would it be also possible for the code to also go into “Appendix C” of every workbook and copy data from columns range D to Y starting from row 6 to row X and paste the data into Master2 sheet.
And then, go into sheet “Appendix D” of every workbook and copy data from columns D to I starting from row 5 to row x and paste the data into Master3 sheet.

Master1,Master2, Master3 sheets will be in one workbook.

In summary:

1. Go into sheet “Appendix B” of every workbook, copy columns range C to F from row 6 to row x, and paste the data into Master1
2. Go into sheet “Appendix C” of every workbook, copy columns range D to Y, starting from row 6 to row x, and paste the data into Master2
3. Go into sheet “Appendix D” of every workbook, copy columns range D to I, starting from row 5 to row x, and paste the data into Master3

Would it be possible to do this in one shot?

Thank you soo much once again, this has definitely saved my life!

 

[mumps]

Try:

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" & Range("C" & Rows.Count).End(xlUp).Row + 1).Copy wkbDest.Sheets("Master1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            .Sheets("Appendix C").Range("D6:Y" & Range("D" & Rows.Count).End(xlUp).Row + 1).Copy wkbDest.Sheets("Master2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            .Sheets("Appendix D").Range("D5:I" & Range("D" & Rows.Count).End(xlUp).Row + 1).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

Don't forget to add the "\" to the path of the folder.

 

[mumps]

Please make one minor change to the code. Delete the "+1" in each of the three copy lines.