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

 

[excel_vba_1]

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

Hi Mumps,

I am getting an error on this line (" run time error "9": subscriipt out of range"):

.Sheets("Appendix B").Range("C6:F" & Range("C" & Rows.Count).End(xlUp).Row).Copy wkbDest.Sheets("Master1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)

Thank you once again!

 

[mumps]

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

 

[excel_vba_1]

Hi Mumps,

I am getting an error on this line (" run time error "9": subscriipt out of range"):

.Sheets("Appendix B").Range("C6:F" & Range("C" & Rows.Count).End(xlUp).Row).Copy wkbDest.Sheets("Master1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)

Thank you once again!

Hi Mumps,

The code you sent me yesterday worked (spelling mismatch)!

But,

I noticed the code did not copy all the rows from some of the workbooks ( from all the 3 sheets).

Also, the masterwork copied rows that are not part of the range, for example:

• Appendix B should start from row 6, but row 1-5 were also copied
• Appendix C should start from row 6, but row 1-5 were also copied
• Appendix D should start from row 5, but row 1-4 were also copied

The only correct workbook copied was the first one, rest made the error metnioned above.

Thank you!!!

 

[mumps]

Did you try the modified macro I suggested in Post# 12?

 

[excel_vba_1]

Did you try the modified macro I suggested in Post# 12?

Hi Mumps,

I have tried the code from post #12 and its works fine, the only problem is when there is no data available to copy in a sheet, the code copies the row just above the given range (rather than just not copying anything).

Is it possible to fix this?

Thanks for your help, you are great!

 

[excel_vba_1]

Hi Mumps,

I have tried the code from post #12 and its works fine, the only problem is when there is no data available to copy in a sheet, the code copies the row just above the given range (rather than just not copying anything).

Is it possible to fix this?

Also, i was wondering if it would be possible to have the workbook name added in an adjacent coloumn to the pasted data in Master1,Master2 and Master3?
For example, in coloumn E of Master1 sheet, it would it populated with the name of the workbook (so i know where the data is coming from).

I really, really appreciate your help!! This has made my life so much easier!=)

 

[Uncle Josh]

This is much more compact than the other code I found to do the same thing. I have to copy data from three separate sheets from each of seven workbooks into three sheets of a master workbook.

During the Copy call, is it possible to copy only the data in each cell, not the formulas? I used named ranges to define a lot of formulas and the CopyRange macro runs with repeated warnings about the same name. If I can just copy the values, I'd be fine.

Thanks,

Uncle Josh
Portland OR

 

[mumps]

Will the workbook name always be in column E of all three Master sheets? This would mean that all of the data in the source sheets is always in columns A to D. Is this correct?

@Uncle Josh: According to Forum rules, you should not post your question in another person's thread. Please start a new thread. If you send me a private message with a link to your thread, I'll be happy to have a look at it.

 

[mumps]

After looking at the code again, I realized that the last unused columns in Master1, Master2 and Master3 will be columns B, Z and J respectively. The workbook name should therefore go in these columns. Try this macro:

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
            If .Sheets("Appendix B").Range("C" & Rows.Count).End(xlUp).Row < 6 Then
            Else
                .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)
                wkbDest.Sheets("Master1").Activate
                fRow = wkbDest.Sheets("Master1").Range("G" & Cells(Rows.Count, "G").End(xlUp).Row).Offset(1, 0).Row
                lRow = wkbDest.Sheets("Master1").Range("G" & Cells(Rows.Count, "A").End(xlUp).Row).Row
                wkbDest.Sheets("Master1").Range("G" & fRow & ":G" & lRow) = wkbSource.Name
            End If
            If .Sheets("Appendix C").Range("D" & Rows.Count).End(xlUp).Row < 6 Then
            Else
                .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)
                wkbDest.Sheets("Master2").Activate
                fRow = wkbDest.Sheets("Master2").Range("Z" & Cells(Rows.Count, "Z").End(xlUp).Row).Offset(1, 0).Row
                lRow = wkbDest.Sheets("Master2").Range("Z" & Cells(Rows.Count, "A").End(xlUp).Row).Row
                wkbDest.Sheets("Master2").Range("Z" & fRow & ":Z" & lRow) = wkbSource.Name
            End If
            If .Sheets("Appendix D").Range("D" & Rows.Count).End(xlUp).Row < 5 Then
            Else
                .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)
                wkbDest.Sheets("Master3").Activate
                fRow = wkbDest.Sheets("Master3").Range("J" & Cells(Rows.Count, "J").End(xlUp).Row).Offset(1, 0).Row
                lRow = wkbDest.Sheets("Master3").Range("J" & Cells(Rows.Count, "A").End(xlUp).Row).Row
                wkbDest.Sheets("Master3").Range("J" & fRow & ":J" & lRow) = wkbSource.Name
            End If
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[excel_vba_1]

After looking at the code again, I realized that the last unused columns in Master1, Master2 and Master3 will be columns B, Z and J respectively. The workbook name should therefore go in these columns. Try this macro:

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
            If .Sheets("Appendix B").Range("C" & Rows.Count).End(xlUp).Row < 6 Then
            Else
                .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)
                wkbDest.Sheets("Master1").Activate
                fRow = wkbDest.Sheets("Master1").Range("G" & Cells(Rows.Count, "G").End(xlUp).Row).Offset(1, 0).Row
                lRow = wkbDest.Sheets("Master1").Range("G" & Cells(Rows.Count, "A").End(xlUp).Row).Row
                wkbDest.Sheets("Master1").Range("G" & fRow & ":G" & lRow) = wkbSource.Name
            End If
            If .Sheets("Appendix C").Range("D" & Rows.Count).End(xlUp).Row < 6 Then
            Else
                .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)
                wkbDest.Sheets("Master2").Activate
                fRow = wkbDest.Sheets("Master2").Range("Z" & Cells(Rows.Count, "Z").End(xlUp).Row).Offset(1, 0).Row
                lRow = wkbDest.Sheets("Master2").Range("Z" & Cells(Rows.Count, "A").End(xlUp).Row).Row
                wkbDest.Sheets("Master2").Range("Z" & fRow & ":Z" & lRow) = wkbSource.Name
            End If
            If .Sheets("Appendix D").Range("D" & Rows.Count).End(xlUp).Row < 5 Then
            Else
                .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)
                wkbDest.Sheets("Master3").Activate
                fRow = wkbDest.Sheets("Master3").Range("J" & Cells(Rows.Count, "J").End(xlUp).Row).Offset(1, 0).Row
                lRow = wkbDest.Sheets("Master3").Range("J" & Cells(Rows.Count, "A").End(xlUp).Row).Row
                wkbDest.Sheets("Master3").Range("J" & fRow & ":J" & lRow) = wkbSource.Name
            End If
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Hi Mumps,

You are simply amazing, thank you so much, the code works( with the workbook name added in the adjacent column)!!!

Thanks once again !! =D