使用VBA将多列转换为多行

Question

我正在尝试执行这种转换。为了说明起见，我将其列为表格，因此基本上应该重复前三列以提供多少种可用颜色。 我搜索了其他类似的种类，但是当我想重复多列时找不到。我在网上找到了此代码，但是它是Name Thank Location Thank Location Thank Location Thank Location Thank Location，并使其如下所示。Name Thank LocationSub createData()Dim dSht As WorksheetDim sSht As WorksheetDim colCount As LongDim endRow As LongDim endRow2 As LongSet dSht = Sheets("Sheet1") 'Where the data sitsSet sSht = Sheets("Sheet2") 'Where the transposed data goessSht.Range("A2:C60000").ClearContentscolCount = dSht.Range("A1").End(xlToRight).Column '// loops through all the columns extracting data where "Thank" isn't blankFor 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 jNext iEnd Sub可以帮我更改我想要的格式吗，我尝试将步骤2更改为1，将j从4更改为开始，但这无济于事。例如，有2套不同的套：2套不同

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

取消枢纽功能：

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

Answer 2

这是使用数组的一种方法（最快吗？）。这种方法比链接的问题更好，因为它不会在循环中读写范围对象。我已经注释了代码，因此您在理解它时应该没有问题。

Option Explicit

Sub Sample()

    Dim wsThis As Worksheet, wsThat As Worksheet

    Dim ThisAr As Variant, ThatAr As Variant

    Dim Lrow As Long, Col As Long

    Dim i As Long, k As Long

    Set wsThis = Sheet1: Set wsThat = Sheet2

    With wsThis

        '~~> Find Last Row in Col A

        Lrow = .Range("A" & .Rows.Count).End(xlUp).Row

        '~~> Find total value in D,E,F so that we can define output array

        Col = Application.WorksheetFunction.CountA(.Range("D2:F" & Lrow))

        '~~> Store the values from the range in an array

        ThisAr = .Range("A2:F" & Lrow).Value

        '~~> Define your new array

        ReDim ThatAr(1 To Col, 1 To 4)

        '~~> Loop through the array and store values in new array

        For i = LBound(ThisAr) To UBound(ThisAr)

            k = k + 1

            ThatAr(k, 1) = ThisAr(i, 1)

            ThatAr(k, 2) = ThisAr(i, 2)

            ThatAr(k, 3) = ThisAr(i, 3)

            '~~> Check for Color 1

            If ThisAr(i, 4) <> "" Then ThatAr(k, 4) = ThisAr(i, 4)

            '~~> Check for Color 2

            If ThisAr(i, 5) <> "" Then

                k = k + 1

                ThatAr(k, 1) = ThisAr(i, 1)

                ThatAr(k, 2) = ThisAr(i, 2)

                ThatAr(k, 3) = ThisAr(i, 3)

                ThatAr(k, 4) = ThisAr(i, 5)

            End If

            '~~> Check for Color 3

            If ThisAr(i, 6) <> "" Then

                k = k + 1

                ThatAr(k, 1) = ThisAr(i, 1)

                ThatAr(k, 2) = ThisAr(i, 2)

                ThatAr(k, 3) = ThisAr(i, 3)

                ThatAr(k, 4) = ThisAr(i, 6)

            End If

        Next i

    End With

    '~~> Create headers in Sheet2

    Sheet2.Range("A1:D1").Value = Sheet1.Range("A1:D1").Value

    '~~> Output the array

    wsThat.Range("A2").Resize(Col, 4).Value = ThatAr

End Sub