获取堆叠列
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