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

 

[LaptopCup]

Is wkbSource (the workbook) password protected or is the "Summary" sheet in wkbSource protected?

I realized when you asked about the protection, I went and checked, there's no password, and it's just specifically on the "Summary" Sheet. I've switched the code to have the unprotect, but now my values are blank for both the A & B columns.

Column A is returning job numbers, so it's a mix of letters and numbers, the formula in the cell is "=Front!D5" - Pulling from the "Front" Sheet (eg: A9999, A9999-1)
Column B is returning Project name, so its text, also pulling from the "Front" sheet - with "=Front!D8" (eg: Residential house in the burbs, commercial building with fencing)

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\joconnor\Desktop\BidSummaries\Data_to_copy\"
ChDir strPath
strExtension = Dir("*.xls*")
Do While strExtension <> ""
Set wkbSource = Workbooks.Open(strPath & strExtension)
With wkbSource
.Sheets("Summary").Unprotect
.Sheets("Summary").Range("D3").Copy wkbDest.Sheets("Sheet1").Range("A1")
.Sheets("Summary").Range("E3").Value = wkbDest.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Value
.Sheets("Summary").Range("D4").Copy wkbDest.Sheets("Sheet1").Range("B1")
.Sheets("Summary").Range("E4").Value = wkbDest.Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
.Sheets("Summary").Range("D5").Copy wkbDest.Sheets("Sheet1").Range("C1")
.Sheets("Summary").Range("E5").Copy wkbDest.Sheets("Sheet1").Cells(Rows.Count, "C").End(xlUp).Offset(1, 0)
.Sheets("Summary").Range("D7").Copy wkbDest.Sheets("Sheet1").Range("D1")
.Sheets("Summary").Range("E7").Copy wkbDest.Sheets("Sheet1").Cells(Rows.Count, "D").End(xlUp).Offset(1, 0)
.Sheets("Summary").Range("O3").Copy wkbDest.Sheets("Sheet1").Range("E1")
.Sheets("Summary").Range("P3").Copy wkbDest.Sheets("Sheet1").Cells(Rows.Count, "E").End(xlUp).Offset(1, 0)
.Sheets("Summary").Range("O5").Copy wkbDest.Sheets("Sheet1").Range("F1")
.Sheets("Summary").Range("P5").Copy wkbDest.Sheets("Sheet1").Cells(Rows.Count, "F").End(xlUp).Offset(1, 0)

Close savechanges:=False
End With
strExtension = Dir
Loop
Application.ScreenUpdating = True
End Sub

 

[mumps]

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:\Destination"
    ChDir strPath
    strExtension = Dir("*.xls*")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        Sheets("Summary").Unprotect
        With wkbDest.Sheets("Sheet1")
            .Range("A1").Value = wkbSource.Sheets("Summary").Range("D3").Value
            .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Value = wkbSource.Sheets("Summary").Range("E3").Value
            .Range("B1").Value = wkbSource.Sheets("Summary").Range("D4").Value
            .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0).Value = wkbSource.Sheets("Summary").Range("E4").Value
            .Range("C1").Value = wkbSource.Sheets("Summary").Range("D5").Value
            .Cells(.Rows.Count, "C").End(xlUp).Offset(1, 0).Value = wkbSource.Sheets("Summary").Range("E5").Value
            .Range("D1").Value = wkbSource.Sheets("Summary").Range("D7").Value
            .Cells(.Rows.Count, "D").End(xlUp).Offset(1, 0).Value = wkbSource.Sheets("Summary").Range("E7").Value
            .Range("E1").Value = wkbSource.Sheets("Summary").Range("O3").Value
            .Cells(.Rows.Count, "E").End(xlUp).Offset(1, 0).Value = wkbSource.Sheets("Summary").Range("P3").Value
            .Range("F1").Value = wkbSource.Sheets("Summary").Range("O5").Value
            .Cells(.Rows.Count, "F").End(xlUp).Offset(1, 0).Value = wkbSource.Sheets("Summary").Range("P5").Value
            .Close savechanges:=False
            '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

 

[LaptopCup]

Works great!

I just had to switch the one lines below, it's been a long time since I was trying to write up some code, but I think it's because the line was trying to close the summary sheet opposed to the entire workbook?

           .Close savechanges:=False

to

            wkbSource.Close Savechanges:=False

There's plenty more lines I plan on adding, but essentially it's just grabbing the data from the summary sheet, and putting it into a single sheet so I can evaluate data. So if there's any hiccups, I'll post them here

Thanks

 

[mumps]

My pleasure.

 

[LaptopCup]

I ran into a problem. Since these sheets are manually filled out, sometimes there's blanks. So I was looking at adding "0" to the rows as they come up blank.

What I was looking to do was adding "Call fill_blanks_with_zeroes" just before my loop ends. Not sure if this is the best way of going about it.

Private Sub fill_blanks_with_zeroes()

Dim LastRow As Integer
Dim LastCol As Integer
With Sheets("Sheet1")
    LastCol = .Cells(1, .Column.Count).End(xlToLeft).Column
End With
   
With Sheets("Sheet1")
    LastRow = Range("A" & .Row.Count).End(xlUp).Row
End With
        If IsEmpty(LastRow, LastCol) Then
            Cell.Value = "0"
        End If
    Next
End Sub

 

[mumps]

I don't quite understand what is happening with the blanks. Can you use the XL2BB add-in (icon in the menu) to attach a screen shot of your data and explain in detail what is happening with the blanks referring to specific cells in the data. De-sensitize the data if necessary.

 

[LaptopCup]

Yeah, I went back and read what I have said... It wasn't all that clear.

Below is a screenshot where I just erased all the data. Essentially, when the "Summary" sheet returns a blank, nothing is filled in, and then the data the is in the next row pushes up to fill that void.

So whenever you see an empty below, the data will actually be pushed up, then obviously all the data doesn't line up anymore.

 

[mumps]

Try:

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook, wkbSource As Workbook, LastRow As Long
    Set wkbDest = ThisWorkbook
    Const strPath As String = "C:\Destination"
    ChDir strPath
    strExtension = Dir("*.xls*")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        Sheets("Summary").Unprotect
        With wkbDest.Sheets("Sheet1")
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
            .Range("A1").Value = wkbSource.Sheets("Summary").Range("D3").Value
            .Cells(LastRow, 1).Value = wkbSource.Sheets("Summary").Range("E3").Value
            .Range("B1").Value = wkbSource.Sheets("Summary").Range("D4").Value
            .Cells(LastRow, 2).Value = wkbSource.Sheets("Summary").Range("E4").Value
            .Range("C1").Value = wkbSource.Sheets("Summary").Range("D5").Value
            .Cells(LastRow, 3).Value = wkbSource.Sheets("Summary").Range("E5").Value
            .Range("D1").Value = wkbSource.Sheets("Summary").Range("D7").Value
            .Cells(LastRow, 4).Value = wkbSource.Sheets("Summary").Range("E7").Value
            .Range("E1").Value = wkbSource.Sheets("Summary").Range("O3").Value
            .Cells(LastRow, 5).Value = wkbSource.Sheets("Summary").Range("P3").Value
            .Range("F1").Value = wkbSource.Sheets("Summary").Range("O5").Value
            .Cells(LastRow, 6).Value = wkbSource.Sheets("Summary").Range("P5").Value
            wkbSource.Close Savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[LaptopCup]

Perrrrfect I tried it on a 60-70 workbooks at once, takes about 7 minutes to run that many, but not a big deal, as the data in these never change historically, so after I have the 100s all the backed up files, going forward will be ideal.

I also realized I didn't need to be pulling the same title over and over again, so I removed those lines and now have the below.

Thanks for the help!

Sub CopyRange()
    Application.ScreenUpdating = False
    Skipblanks = False
    Dim wkbDest As Workbook
    Dim rng As Range
    Dim wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Dim LastRow As Long
    Const strPath As String = "C:\destination"
    ChDir strPath
    strExtension = Dir("*.xls*")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        Sheets("Summary").Unprotect
        With wkbDest.Sheets("Sheet1")
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
            'Use this formula to grab titles
            '.Range("A1").Value = wkbSource.Sheets("Summary").Range("D3").Value
            .Cells(LastRow, 1).Value = wkbSource.Sheets("Summary").Range("E3").Value
            .Cells(LastRow, 2).Value = wkbSource.Sheets("Summary").Range("E4").Value
            .Cells(LastRow, 3).Value = wkbSource.Sheets("Summary").Range("E5").Value
            .Cells(LastRow, 4).Value = wkbSource.Sheets("Summary").Range("E7").Value
            .Cells(LastRow, 5).Value = wkbSource.Sheets("Summary").Range("P3").Value
            .Cells(LastRow, 6).Value = wkbSource.Sheets("Summary").Range("P5").Value
            .Cells(LastRow, 8).Value = wkbSource.Sheets("Summary").Range("I18").Value
            .Cells(LastRow, 9).Value = wkbSource.Sheets("Summary").Range("L18").Value
            .Cells(LastRow, 10).Value = wkbSource.Sheets("Summary").Range("E26").Value
            .Cells(LastRow, 11).Value = wkbSource.Sheets("Summary").Range("E27").Value
            .Cells(LastRow, 12).Value = wkbSource.Sheets("Summary").Range("E28").Value
            .Cells(LastRow, 13).Value = wkbSource.Sheets("Summary").Range("L29").Value
            .Cells(LastRow, 14).Value = wkbSource.Sheets("Summary").Range("I39").Value
            .Cells(LastRow, 15).Value = wkbSource.Sheets("Summary").Range("E39").Value
            .Cells(LastRow, 16).Value = wkbSource.Sheets("Summary").Range("G42").Value
            .Cells(LastRow, 17).Value = wkbSource.Sheets("Summary").Range("G43").Value
            .Cells(LastRow, 18).Value = wkbSource.Sheets("Summary").Range("E46").Value
            .Cells(LastRow, 19).Value = wkbSource.Sheets("Summary").Range("I71").Value
            .Cells(LastRow, 20).Value = wkbSource.Sheets("Summary").Range("J74").Value
            .Cells(LastRow, 21).Value = wkbSource.Sheets("Summary").Range("S22").Value
            .Cells(LastRow, 22).Value = wkbSource.Sheets("Summary").Range("N33").Value
            .Cells(LastRow, 23).Value = wkbSource.Sheets("Summary").Range("S42").Value
            .Cells(LastRow, 24).Value = wkbSource.Sheets("Summary").Range("M42").Value
            .Cells(LastRow, 25).Value = wkbSource.Sheets("Summary").Range("P54").Value
            .Cells(LastRow, 26).Value = wkbSource.Sheets("Summary").Range("R57").Value
            .Cells(LastRow, 27).Value = wkbSource.Sheets("Summary").Range("M64").Value
            .Cells(LastRow, 28).Value = wkbSource.Sheets("Summary").Range("N64").Value
            wkbSource.Close Savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[mumps]

My pleasure.