Copying selections of cells from multiple workbooks with multiple sheets to paste into a single worksheet with VBA

Question

I need to copy ranges of cells from multiple workbooks that have multiple worksheets to a single worksheet in another workbook.

The source worksheets are laid out in the same way though with different amounts of data. Top row has column headers and in terms of data I am copying I am only interested in columns A to J (first ten). I am additionally using column L to calculate how many times I need to carry out the copy and paste function but will not copy data from that column.

Each range within each worksheet is separated by two rows that I do not need to copy. Also, there is formatting and merging in the original workbooks that I am not interested but can remove once all the data is copied over.

I am building up the method bit by bit but have become stuck on how to incrementally copy the ranges of cells I am interested in and paste. I have code that copies, but in my for-next loop, the paste range gets overwritten rather than pasted underneath.

Once I can resolve this, I will then modify the code to copy from all the worksheets within each workbook. At the moment, it is just from one worksheet, and I am pasting within the same sheet underneath the copy data.

Example data to copy:

Example source data but without formatting here

How I want the data to look like: Example data as I would like it pasted here

This is the code I have so far

Sub CopyRangeMultiple_Method()

    Dim OffsetAmount As Integer
    OffsetAmount = 7
    Dim FirstRoomMon As Integer
    FirstRoomMon = 2 'For the first room to copy, Monday starts at the second row.
    Dim FirstRoomFri As Integer
    FirstRoomFri = 6 'For the first room to copy, Friday starts at the sixth row.
    Dim FirstRoom As Range
    Set FirstRoom = Range(Cells(FirstRoomMon, 1), Cells(FirstRoomFri, 10)) 'first room in the list, monday to friday all day.
    Dim NextRoom As Range
    Dim TotalRooms As Integer
    TotalRooms = WorksheetFunction.CountIf(Range("L:L"), "Weekly Total") 'each room has a weekly total => this will return the total no. of rooms.
    Dim RoomNo As Integer
    Dim PasteRangeStart As Range
    Set PasteRangeStart = Worksheets("Test").Range("A210") 'start of the paste range.
    
        
    For RoomNo = 1 To TotalRooms - 1
        FirstRoom.Copy PasteRangeStart 'copy and paste the first range
        'set up the next room/range to copy
        Set NextRoom = Range(Cells(FirstRoomMon + (OffsetAmount * RoomNo), 1), Cells(FirstRoomFri + (OffsetAmount * RoomNo), 10))
        'Union(FirstRoom, NextRoom).Copy Worksheets("Test").Range("A210")
        NextRoom.Copy PasteRangeStart.Offset(5, 0)
            
    Next RoomNo
        
End Sub

I can see the code is copying each section/range I want and pasting and then copying the next range but pasting over the previous range. I thought the Offset function on the PasteRangeStart would take the paste range down by five rows each time but it does not.

Answer 1

The problem with your code is that the PasteRangeStart is hard coded:

Set PasteRangeStart = Worksheets("Test").Range("A210") 'start of the paste range.
NextRoom.Copy PasteRangeStart.Offset(5, 0)

This should fix it:

Dim PasteRangeStart As Range

For RoomNo = 1 To TotalRooms - 1
    With Worksheets("Test")
        Set PasteRangeStart = .Range("A" & .Rwos.Count).End(xlUp)
    End With
    FirstRoom.Copy PasteRangeStart 'copy and paste the first range
    'set up the next room/range to copy
    Set NextRoom = Range(Cells(FirstRoomMon + (OffsetAmount * RoomNo), 1), Cells(FirstRoomFri + (OffsetAmount * RoomNo), 10))
    'Union(FirstRoom, NextRoom).Copy Worksheets("Test").Range("A210")
    NextRoom.Copy PasteRangeStart.Offset(5, 0)
        
Next RoomNo

If you just want to copy the values then using arrays is much more efficient. When I have to append values I create a sub to append the data and one to collect the data. In the code below I add the row data to a collection, create an array to hold the results sized to the collection count, and append data. I also use another sub to make pass the worksheets into my code that collects the data.

Sub CopyRangeMultiple_Method()
    
   ProcessRooms Workbooks("SomeWorkbook").Worksheets("Rooms")
   ProcessRooms Workbooks("SomeOtherWorkbook").Worksheets("Rooms")
End Sub

Sub ProcessRooms(ws As Worksheet)
    Const NumberOfColumns As Long = 10
    Dim Target As Range
    Set Target = ws.UsedRange.Columns("A").Resize(, NumberOfColumns).Offset(1)
    Dim Data As Variant
    Data = Target.Value
    
    Dim Map As New Collection
    
    Dim r As Long, c As Long
    Dim RowData As Variant
    
    For r = 1 To UBound(Data)
        If Len(Data(r, 1)) > 0 Then
            ReDim RowData(1 To 1, 1 To NumberOfColumns)
            For c = 1 To NumberOfColumns
                RowData(1, c) = Data(r, c)
            Next
            Map.Add RowData
        End If
    Next
    
    Dim Results As Variant
    ReDim Results(1 To Map.Count, 1 To NumberOfColumns)
    
    For r = 1 To Map.Count
        RowData = Map(r)

        For c = 1 To NumberOfColumns
            Results(r, c) = RowData(1, c)
        Next
        Map.Add RowData
    Next
    
    AppendRooms Results
End Sub

Function wsRooms() As Worksheet
    Set wsRooms = ThisWorkbook.Worksheets("Test")
End Function

Sub AppendRooms(Data As Variant)
    Application.ScreenUpdating = False
    Dim Target As Range
    
    With wsRooms
        Set Target = .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
    End With
    
    Target.Resize(UBound(Data), UBound(Data, 2)).Value = Data
End Sub