Paste from multiple Excel workbooks into one workbook (Across the page & file names)

  • Hello

    I’m new to Macros and VBA and I was hoping that someone could help me with a task I want to complete, here are the details;

    I have a folder and in that folder are a number of Excel workbooks. For this task I need to be able to consolidate the data from a range of cells in a particular worksheet (called Appendix B in each one) in these workbooks into one worksheet called Master (in a separate workbook). This is what I have so far in terms of code, and it works great.

    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\cmarsh\Desktop\group_1"
    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("A1:D" & LastRow).Copy wkbDest.Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
    .Close savechanges:=False
    End With
    strExtension = Dir
    Application.ScreenUpdating = True
    End Sub

    Result example


    However I want to expand on this so that instead of the data going down the page it goes horizontally across the page, I also want to add the source workbook name to the top of each section, please see an example below;

    Required result example


    Is this possible???

    Any help would be appreciated.


  • Hi Claire,

    Try this


  • Hi Gizzmo

    Thanks for getting back to me, when I run the above I get the below error message (I've put the file structure in the red box if it's of any use)


    Thanks for your help!


  • Hi Claire,

    Try changing

    Const strPath As String = "C:\Users\cmarsh\Desktop\group_1"


    Const strPath As String = "C:\Users\cmarsh\Desktop\group_1\"

    Also see my edit to my original reply as I changed the code to allow for workbook name.


  • Change

    .Sheets("Appendix B").Range("A1:D" & LastRow).Copy wkbDest.Sheets("Master").Cells(2, rLastCell.Column + 1)


    wkbDest.Sheets("Master").Cells(2, rLastCell.Column + 1).Resize(LastRow, 4).Value = .Sheets("Appendix B").Range("A1:D" & LastRow).Value

    Please note I am assuming your data is always going to be 4 Columns wide...hence "Resize(LastRow,4)" in the code snippet above.

  • Hi I believe it will always be four columns across however I have noticed one or two other projects have six columns so I'm guessing I would just change the "LastRow,4" to "LastRow6"

  • Ok if that's the case, and this is messy, only because I am no expert, but try this code instead, hopefully it will cater for row and column sizes being different between workbooks


Participate now!

Don’t have an account yet? Register yourself now and be a part of our community!