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

问题描述

我正在尝试执行这种转换.为了便于说明，我将其作为表格进行了说明，因此基本上应该重复前三列以提供多少种可用颜色.

This kind of transformation is what I was trying to perform. Just for illustration I have made this as table.So basically the first 3 column should repeat for how many ever colors are available.

我搜索了其他类似的种类，但是当我想重复多列时找不到. 我在网上找到了此代码，但是 姓名谢谢地点谢谢地点谢谢地点谢谢地点 并使其如下所示 名字谢谢位置

I searched for other similar kinds but could not find when I want multiple columns to repeat. I found this code online but it is Name Thank Location Thank Location Thank Location Thank Location and makes it like below Name Thank Location

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更改为开始，但这无济于事 另一个具有2个不同集的示例:

Could some one help in changing the format I want, I tried changing step 2 to 1 and j to start from 4 but that was not helpful Another eg with 2 varied sets:

推荐答案

这是一种通用的非透视"方法(所有固定"列都必须出现在输入数据的左侧)

Here's a generic "unpivot" approach (all "fixed" columns must appear on the left of the input data)

测试子:

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

取消枢纽功能:

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屋！