使用VBA

Question

这种转变正是我试图表现的。仅仅是为了说明我把它作为表格。所以基本上第3列应该重复有多少颜色可用。

我搜索了其他类似的类型，但是当我想要多个列重复时找不到。 我在网上找到了这个代码，但确实如此 姓名感谢位置感谢位置感谢位置感谢位置 并使它像下面 名称感谢地点

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​​个不同的集合：

Answer 1

这是一种通用的“unpivot”方法（所有“固定”列必须出现在输入数据的左侧）

测试子：

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

Answer 2

这是使用数组的一种方式（最快？）。这种方法比linked question更好，因为它不会在循环中读取和写入范围对象。我已对代码进行了评论，因此您不应该在理解它时遇到问题。

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

<强> SHEET1

<强> SHEET2

Answer 3

LET 函数的添加允许此非 VBA 解决方案。

=LET(data,B3:F6,
     dataRows,ROWS(data),
     dataCols,COLUMNS(data),
     rowHeaders,OFFSET(data,0,-1,dataRows,1),
     colHeaders,OFFSET(data,-1,0,1,dataCols),
     dataIndex,SEQUENCE(dataRows*dataCols),
     rowIndex,MOD(dataIndex-1,dataRows)+1,
     colIndex,INT((dataIndex-1)/dataRows)+1,
     FILTER(CHOOSE({1,2,3}, INDEX(rowHeaders,rowIndex), INDEX(colHeaders,colIndex), INDEX(data,rowIndex,colIndex)), index(data,rowIndex,colIndex)<>""))