excel - 使用 VBA 将多列转置为多行

Question

这就是我正在尝试执行的转变。
为了便于说明，我将其制成表格。基本上，无论有多少种颜色可用，前三列都应该重复。

我搜索了类似的问题，但找不到何时需要重复多列。

我在网上找到了这段代码

Sub createData()
    Dim dSht As Worksheet
    Dim sSht As Worksheet
    Dim colCount As Long
    Dim endRow As Long
    Dim endRow2 As Long
     
    Set dSht = Sheets("Sheet1") 'Where the data sits
    Set sSht = Sheets("Sheet2") 'Where the transposed data goes
     
    sSht.Range("A2:C60000").ClearContents
    colCount = dSht.Range("A1").End(xlToRight).Column
     
     '// loops through all the columns extracting data where "Thank" isn't blank
    For i = 2 To colCount Step 2
        endRow = dSht.Cells(1, i).End(xlDown).Row
        For j = 2 To endRow
            If dSht.Cells(j, i) <> "" Then
                endRow2 = sSht.Range("A50000").End(xlUp).Row + 1
                sSht.Range("A" & endRow2) = dSht.Range("A" & j)
                sSht.Range("B" & endRow2) = dSht.Cells(j, i)
                sSht.Range("C" & endRow2) = dSht.Cells(j, i).Offset(0, 1)
            End If
        Next j
    Next i
End Sub

我尝试将步骤 2 更改为 1，并将 j 从 4 开始。

另一个具有两个不同集合的示例:

Answer 1

这是一种通用的“取消透视”方法(所有“固定”列必须出现在要取消透视的列的左侧)

测试子:

Sub Tester()
    
    Dim p
    
    'get the unpivoted data as a 2-D array
    p = UnPivotData(Sheets("Sheet1").Range("A1").CurrentRegion, _
                  3, False, False)
                
    With Sheets("Sheet1").Range("H1")
        .CurrentRegion.ClearContents
        .Resize(UBound(p, 1), UBound(p, 2)).Value = p 'populate array to sheet
    End With

    'EDIT: alternative (slower) method to populate the sheet
    '      from the pivoted dataset.  Might need to use this
    '      if you have a large amount of data
    'Dim r As Long, c As Long
    'For r = 1 To Ubound(p, 1)
    'For c = 1 To Ubound(p, 2)
    '    Sheets("Sheet2").Cells(r, c).Value = p(r, c)
    'Next c
    'Next r

End Sub

UnPivot 函数 - 不需要任何修改:

Function UnPivotData(rngSrc As Range, fixedCols As Long, _
                   Optional AddCategoryColumn As Boolean = True, _
                   Optional IncludeBlanks As Boolean = True)

    Dim nR As Long, nC As Long, data, dOut()
    Dim r As Long, c As Long, rOut As Long, cOut As Long, cat As Long
    Dim outRows As Long, outCols As Long
    
    data = rngSrc.Value 'get the whole table as a 2-D array
    nR = UBound(data, 1) 'how many rows
    nC = UBound(data, 2) 'how many cols

    'calculate the size of the final unpivoted table
    outRows = nR * (nC - fixedCols)
    outCols = fixedCols + IIf(AddCategoryColumn, 2, 1)
    
    'resize the output array
    ReDim dOut(1 To outRows, 1 To outCols)
               
    'populate the header row
    For c = 1 To fixedCols
        dOut(1, c) = data(1, c)
    Next c
    If AddCategoryColumn Then
        dOut(1, fixedCols + 1) = "Category"
        dOut(1, fixedCols + 2) = "Value"
    Else
        dOut(1, fixedCols + 1) = "Value"
    End If
    
    'populate the data
    rOut = 1
    For r = 2 To nR
        For cat = fixedCols + 1 To nC
            
            If IncludeBlanks Or Len(data(r, cat)) > 0 Then
                rOut = rOut + 1
                'Fixed columns...
                For c = 1 To fixedCols
                    dOut(rOut, c) = data(r, c)
                Next c
                'populate unpivoted values
                If AddCategoryColumn Then
                    dOut(rOut, fixedCols + 1) = data(1, cat)
                    dOut(rOut, fixedCols + 2) = data(r, cat)
                Else
                    dOut(rOut, fixedCols + 1) = data(r, cat)
                End If
            End If

        Next cat
    Next r
    
    UnPivotData = dOut
End Function