VBA: How do I merge several columns into 1 ? My current code works but only <450 rows

Question

I would like some guidance, I am trying to merge multiple columns into 1 (see screenshot).

I was wondering if someone please could help me understand why the function below stops working after about 450 rows ? I need it to go up to 10000 rows.

And possibly a better way to do this?

Column BZ and CA (yellow) contains the array formula :

BZ =MergeRanges(P3:P10000;R3:R10000;T3:T10000;V3:V10000;X3:X10000;Z3:Z10000;AB3:AB10000;AD3:AD10000;AF3:AF10000;AH3:AH10000;AJ3:AJ10000;AL3:AL10000;AN3:AN10000;AP3:AP10000;AR3:AR10000;AT3:AT10000;AV3:AV10000;AX3:AX10000;AZ3:AZ10000;BB3:BB10000;BD3:BD10000;BF3:BF10000;BH3:BH10000;BJ3:BJ10000;BL3:BL10000;BN3:BN10000;BP3:BP10000;BR3:BR10000;BT3:BT10000;BV3:BV10000;BX3:BX10000)

CA =MergeRanges(Q3:Q10000;S3:S10000;U3:U10000;W3:W10000;Y3:Y10000;AA3:AA10000;AC3:AC10000;AE3:AE10000;AG3:AG10000;AI3:AI10000;AK3:AK10000;AM3:AM10000;AO3:AO10000;AQ3:AQ10000;AS3:AS10000;AU3:AU10000;AW3:AW10000;AY3:AY10000;BA3:BA10000;BC3:BC10000;BE3:BE10000;BG3:BG10000;BI3:BI10000;BK3:BK10000;BM3:BM10000;BO3:BO10000;BQ3:BQ10000;BS3:BS10000;BU3:BU10000;BW3:BW10000;BY3:BY10000)

VBA

Function MergeRanges(ParamArray arguments() As Variant) As Variant()
Dim cell As Range, temp() As Variant
ReDim temp(0)

For Each argument In arguments
  For Each cell In argument
    If cell <> "" Then
      temp(UBound(temp)) = cell
      ReDim Preserve temp(UBound(temp) + 1)
    End If
  Next cell
Next argument

ReDim Preserve temp(UBound(temp) - 1)
MergeRanges = Application.Transpose(temp)

End Function

Thanks a lot

EDIT

I found a way to make it work without a function. See example below but with only 6 columns to simplify. However, as my actual purpose requires 31x2 rows, I need to repeat the example below into 62 lines. So it is loooooong and ugly.

Sub StackEm1()

Range("A3:A" & Cells(Rows.Count, "A").End(xlUp).Row).Copy
    Range("H3").PasteSpecial xlPasteValues

Range("C3:C" & Cells(Rows.Count, "C").End(xlUp).Row).Copy
    Range("H" & Cells(Rows.Count, "H").End(xlUp).Row + 1).PasteSpecial xlPasteValues
    
Range("E3:E" & Cells(Rows.Count, "E").End(xlUp).Row).Copy
    Range("H" & Cells(Rows.Count, "H").End(xlUp).Row + 1).PasteSpecial xlPasteValues
    
    Call StackEm2

End Sub

Sub StackEm2()

Range("B3:B" & Cells(Rows.Count, "B").End(xlUp).Row).Copy
    Range("I3").PasteSpecial xlPasteValues

Range("D3:D" & Cells(Rows.Count, "D").End(xlUp).Row).Copy
    Range("I" & Cells(Rows.Count, "I").End(xlUp).Row + 1).PasteSpecial xlPasteValues
    
Range("F3:F" & Cells(Rows.Count, "F").End(xlUp).Row).Copy
    Range("I" & Cells(Rows.Count, "I").End(xlUp).Row + 1).PasteSpecial xlPasteValues

End Sub

Result

Answer 1

Get Stacked Columns

Excel Formula

• You can use the following formula to get the desired result:

   =INDEX(P$3:BX$10000,MOD(ROW()-3,9998)+1,2*INT((ROW()-3)/9998)+1)

  Use the formula in cell BZ3 and copy down to CA309940 . Use common logic if the values are different, eg 9998 = 10000 - 3 + 1 ...etc.

  For the posted image the formula would be:

   =INDEX(P$3:BX$32,MOD(ROW()-3,30)+1,2*INT((ROW()-3)/30)+1)

VBA

The code consists of three procedures:

• The first is the getStackedColumns function, the 'star of the show'.
• The second is a simple test with a small amount of data with which you can easily learn what the function exactly does.
• The third is a practical (hard coded, simplified for the ActiveSheet ) example which you can run to get the data into the appropriate two ranges (columns). It took 3 seconds (without any caluclations) on my machine, which makes me wonder that if you would put a formula into every cell in those columns, how (in)efficient this would become (309938 cells per column).

The Code

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Writes the values of mulitple given ranges, by column,
'               to a 2D one-based one-column array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function getStackedColumns(ParamArray Ranges() As Variant) _
         As Variant
    
' Ranges() - 'Ranges Array'
' Each element of 'Ranges Array' - 'current Source Range'
' Sources - 'Sources Array' (a jagged array of arrays)
' Each element of 'Sources Array' - 'current Source Array'
    
' Initialize error handling.
    
    Const ProcName As String = "getStackedColumns"
    On Error GoTo clearError ' Turn on error trapping.
    
' Write values from Ranges Array to Sources Array.
    
    ' Validate Ranges Array: check if there are any elements.
    If UBound(Ranges) < LBound(Ranges) Then
        GoTo NoElements
    End If
    
    ' Define Sources Array, resize it to the size or Ranges Array.
    Dim Sources As Variant
    ReDim Sources(1 To UBound(Ranges) - LBound(Ranges) + 1)
    
    ' Define One-Cell Array to help when a range contains one cell only.
    Dim OneCell As Variant
    ReDim OneCell(1 To 1, 1 To 1)
    
    ' Declare variables for upcoming 'For Each Next' loop.
    Dim rng As Variant  ' Current (Source Range) Element in Ranges Array
    Dim tRows As Long   ' Target (Array) Number of Rows
    Dim rCount As Long  ' Current Source Rows Count
    Dim cCount As Long  ' Current Source Columns Count
    Dim sCount As Long  ' Subscript of Current Source Array
    
    ' Loop through (iterate) elements (ranges) in Ranges Array.
    For Each rng In Ranges
        ' Validate current Source Range in Ranges Array.
        If TypeName(rng) = "Range" Then
            ' Define subscript of current Source Array.
            sCount = sCount + 1
            ' Define number of rows in current Source Range.
            rCount = rng.Rows.Count
            ' Define number of columns in current Source Range.
            cCount = rng.Columns.Count
            ' Check if there is more than one cell in current Source Range.
            If rCount > 1 Or cCount > 1 Then
                ' Write values from current Source Range
                ' to current Source Array.
                Sources(sCount) = rng.Value
            Else
                ' Copy One-Cell Array, which is becoming current Source Array,
                ' to Sources Array.
                Sources(sCount) = OneCell
                ' Write the only value in current Source (Cell) Range
                ' to the only element of current Source Array.
                Sources(sCount)(1, 1) = rng.Value
            End If
            ' Add the product of current Source Arrays rows and columns
            ' to Target Number of Rows.
            tRows = tRows + rCount * cCount
        End If
    Next rng
    
    ' Validate Sources Array: check if there are any elements.
    If sCount = 0 Then
        GoTo NoRanges
    End If
    
' Write values from arrays of Sources Array to Target Array.
    
    ' Define Target Array.
    Dim Target As Variant
    ReDim Target(1 To tRows, 1 To 1)
    
    ' Declare counter variables (counters) for the upcoming 'For Next' loop.
    Dim sCol As Long ' Source Column Counter (Current Column in Source Array)
    Dim sRow As Long ' Source Row Counter (Current Row in Source Array)
    Dim tRow As Long ' Target Row Counter (Current Row in Target Array)
    
    ' Loop through (iterate) Source Arrays (of Sources Array).
    For sCount = 1 To sCount
        ' Loop through (iterate) columns of current Source Array.
        For sCol = 1 To UBound(Sources(sCount), 2)
            ' Loop through (iterate) rows of current Source Array.
            For sRow = 1 To UBound(Sources(sCount), 1)
                ' Define current row of Target array.
                tRow = tRow + 1
                ' Write value from current element of Source Array
                ' to current element of Target Array.
                Target(tRow, 1) = Sources(sCount)(sRow, sCol)
            Next sRow
        Next sCol
    Next sCount
    
' Write result and exit (Success).
    
    getStackedColumns = Target
    GoTo ProcExit

' Labels (Fail)

NoElements:
    Debug.Print "'" & ProcName & "': No elements found."
    GoTo ProcExit

NoRanges:
    Debug.Print "'" & ProcName & "': No ranges found."
    GoTo ProcExit

clearError:
    Debug.Print "'" & ProcName & "': " & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    On Error GoTo 0 ' Turn off error trapping.
    GoTo ProcExit

' Exit

ProcExit:

End Function

Sub testGetStackedColumnRanges()
    
    ' Test No Elements.
    Dim Data As Variant
    Data = getStackedColumns()
    ' There is no result. Data is empty. The message in the Immediate window is:
    ' 'getStackedColumns': No elements found.

    ' Test No Range.
    Dim rng As Range
    Data = getStackedColumns(rng) ' rng is Nothing.
    ' There is no result. Data is empty. The message in the Immediate window is:
    ' 'getStackedColumns': No ranges found.
    
    ' Test with bad inputs.
    Data = getStackedColumns([A1], , 1.12, 13, [B1:B2], True, Nothing, [C1:D2])
    If Not IsEmpty(Data) Then
        Dim tRow As Long
        For tRow = 1 To UBound(Data)
            Debug.Print Data(tRow, 1)
        Next tRow
    End If
    ' The result are the values from the following cells:
    '  A1
    '  B1
    '  B2
    '  C1
    '  C2
    '  D1
    '  D2

End Sub

Sub writeStackedColumns()
    
    Dim Data As Variant
    ReDim Data(1 To 2)
    
    Data(1) = getStackedColumns([P3:P10000], [R3:R10000], [T3:T10000], _
                                [V3:V10000], [X3:X10000], [Z3:Z10000], _
                                [AB3:AB10000], [AD3:AD10000], [AF3:AF10000], _
                                [AH3:AH10000], [AJ3:AJ10000], [AL3:AL10000], _
                                [AN3:AN10000], [AP3:AP10000], [AR3:AR10000], _
                                [AT3:AT10000], [AV3:AV10000], [AX3:AX10000], _
                                [AZ3:AZ10000], [BB3:BB10000], [BD3:BD10000], _
                                [BF3:BF10000], [BH3:BH10000], [BJ3:BJ10000], _
                                [BL3:BL10000], [BN3:BN10000], [BP3:BP10000], _
                                [BR3:BR10000], [BT3:BT10000], [BV3:BV10000], _
                                [BX3:BX10000])
    
    Data(2) = getStackedColumns([Q3:Q10000], [S3:S10000], [U3:U10000], _
                                [W3:W10000], [Y3:Y10000], [AA3:AA10000], _
                                [AC3:AC10000], [AE3:AE10000], [AG3:AG10000], _
                                [AI3:AI10000], [AK3:AK10000], [AM3:AM10000], _
                                [AO3:AO10000], [AQ3:AQ10000], [AS3:AS10000], _
                                [AU3:AU10000], [AW3:AW10000], [AY3:AY10000], _
                                [BA3:BA10000], [BC3:BC10000], [BE3:BE10000], _
                                [BG3:BG10000], [BI3:BI10000], [BK3:BK10000], _
                                [BM3:BM10000], [BO3:BO10000], [BQ3:BQ10000], _
                                [BS3:BS10000], [BU3:BU10000], [BW3:BW10000], _
                                [BY3:BY10000])
    
    [BZ3].Resize(UBound(Data(1))).Value = Data(1)
    [CA3].Resize(UBound(Data(2))).Value = Data(2)

End Sub