VBA to copy data from multiple workbooks into master sheet

Status
Not open for further replies.

excel_vba_1

New Member
Joined
Nov 2, 2015
Messages
20
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! =)
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
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.
Code:
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
 
Upvote 0
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.
Code:
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?
 
Upvote 0
I had an extra space in one of the lines. Try:
Code:
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
 
Upvote 0
I had an extra space in one of the lines. Try:
Code:
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.
 
Upvote 0
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 =)
 
Upvote 0
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!
 
Upvote 0
Try:
Code:
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.
 
Upvote 0
Please make one minor change to the code. Delete the "+1" in each of the three copy lines.
 
Upvote 0
Status
Not open for further replies.

Forum statistics

Threads
1,213,551
Messages
6,114,266
Members
448,558
Latest member
aivin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top