使用 VBA 将多列转换为多行 [英] Transpose multiple columns to multiple rows with VBA

问题描述

这就是我正在尝试执行的转换.
为了说明，我把它做成了桌子.基本上前三列应该重复，无论有多少颜色可用.

This is the kind of transformation is what I am trying to perform.
For illustration I made this as table. Basically the first three columns should repeat for however many colors are available.

我搜索了类似的问题，但在我想要重复多列时找不到.

I searched for similar questions but could not find when I want multiple columns to repeat.

我在网上找到了这个代码

I found this code online

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 开始.

I tried changing step 2 to 1 and j to start from 4.

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

Another example with two varied sets:

推荐答案

这是一个通用的unpivot"方法(所有固定"列必须出现在列的左侧才能取消透视)

Here's a generic "unpivot" approach (all "fixed" columns must appear on the left of the columns to be unpivoted)

测试子:

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 函数 - 不需要任何修改:

UnPivot function - should not need any modifications:

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

这篇关于使用 VBA 将多列转换为多行的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！