arrays - VBA：如何将几列合并为 1 ？我当前的代码有效，但只有 <450 行

Question

我想要一些指导，我正在尝试将多列合并为 1（见屏幕截图）。

我想知道是否有人可以帮助我理解为什么下面的函数在大约 450 行后停止工作？我需要它达到 10000 行。

并且可能有更好的方法来做到这一点？

列BZ和CA（黄色）包含数组公式：

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

非常感谢

编辑

我找到了一种让它在没有功能的情况下工作的方法。请参见下面的示例，但只需简化 6 列。但是，由于我的实际目的需要 31x2 行，我需要将下面的示例重复为 62 行。所以它是loooooong和丑陋的。

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

结果

标签： arraysexcelvbafunction

Answer 1

获取堆叠列

Excel公式

• 您可以使用以下公式来获得所需的结果：

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

  使用单元格中的公式BZ3并复制到CA309940. 如果值不同，请使用通用逻辑，例如 9998 = 10000 - 3 + 1 ...等。

  对于发布的图像，公式为：

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

VBA

代码由三个过程组成：

• 第一个是getStackedColumns功能，“节目之星”。
• 第二个是使用少量数据的简单测试，您可以通过它轻松了解该函数的确切作用。
• 第三个是一个实用的（硬编码，简化为ActiveSheet）示例，您可以运行该示例以将数据放入适当的两个范围（列）中。在我的机器上花了 3 秒（没有任何计算），这让我想知道如果你将一个公式放入这些列中的每个单元格，这将变得多么（低）效率（每列 309938 个单元格）。

编码

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 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