Copy ranges on diff sheets into one array

[quitethenovice]

Hello friends,

I have five sheets that that I need to copy the data from each into one array and paste into the 6th sheet. The sheets may not all exist, and the number of columns is the same but the rows will be different.

The ranges to copy are:

Sheets("One").Range("A2:M" & Sheets("One").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Two").Range("A2:M" & Sheets("One").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Three").Range("A2:M" & Sheets("One").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Four").Range("A2:M" & Sheets("One").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Five").Range("A2:M" & Sheets("One").Range("A" & Rows.Count).End(xlUp).Row

Output:

Sheets("Final").Range("A2:M2")

Kind regards

Fred

 

[rlv01]

Try this.

Sub ArrCopy()
    Dim VA() As Variant, FinalArr() As Variant
    Dim I As Long, MaxSize As Long, J As Long, K As Long, L As Long
    Dim rng As Range
    Dim WS As Worksheet

    I = 0
    MaxSize = 0
    ReDim VA(99)
    For Each WS In ActiveWorkbook.Worksheets
        With WS
            Select Case .Name
            Case "One", "Two", "Three", "Four", "Five"
                VA(I) = .Range("A2:M" & .Range("A" & .Rows.Count).End(xlUp).Row).Value
                MaxSize = MaxSize + UBound(VA(I), 1)
                I = I + 1
            End Select
        End With
    Next WS
    
    If MaxSize > 0 Then
        ReDim Preserve VA(I - 1)
        ReDim FinalArr(1 To MaxSize, 1 To UBound(VA(0), 2))

        K = 1
        For I = LBound(VA) To UBound(VA)
        Debug.Print I
            For J = 1 To UBound(VA(I), 1)
                For L = 1 To UBound(FinalArr, 2)
                    FinalArr(K, L) = VA(I)(J, L)
                Next L
                K = K + 1
            Next J
        Next I

        With Worksheets("Final")
            Set rng = .Range("A2").Resize(UBound(FinalArr, 1), UBound(FinalArr, 2))
            rng.EntireColumn.ClearContents
            rng.Value = FinalArr
        End With
    End If
End Sub

 

[Rick Rothstein]

Does this macro do what you want...

Sub CopyRangesToFinalSheet()
  Dim WS As Worksheet
  For Each WS In Sheets(Array("One", "Two", "Three", "Four", "Five"))
    WS.Range("A2:M" & WS.Cells(Rows.Count, "A").End(xlUp).Row).Copy Sheets("Final").Cells(Rows.Count, "A").End(xlUp).Offset(1)
  Next
End Sub

 

[quitethenovice]

@Rick Rothstein and @rlv01, thank you both very much!

@Rick Rothstein I had an error because one of the sheets didn't exist.

@rlv01, working great thanks.