使用Excel vba轉置矩陣的重復范圍

Question

我遇到一種情況，我有多組矩陣要轉置，並希望對Excel vba代碼有所幫助。 預先感謝您的幫助。

我的表如下-（這將是13個月的視圖，但此示例僅顯示3個）

Group   month   color   shape   cost
A       Jan      B        S         1
A       Feb      G        T         2
A       Mar      Y        R         3
B       Jan      W        C         5
B       Feb      M        S         4
B       Mar      P        R         7

依此類推（更多的組，更多的月）期望的結果-

Group       Jan Feb Mar
A   color   B   G   Y   
    shape   S   T   R
    cost    1   2   3
B   color   W   M   P
    shape   C   S   R
    cost    5   4   7

依此類推（將其值轉置）

示例代碼不能完全給出上述結果，但是我已經開始使用了。

Sub transposedata()
Dim vcol1 As Variant, vcol2 As Variant, vcol3 As Variant, vcol4 As Variant, vcol5 As Variant, vcol6 As Variant
Dim lastrow As Long
Dim ws As Worksheet


Set ws = Sheets(1)

lastrow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row

lastrow = lastrow - 1

vcol1 = WorksheetFunction.transpose(ws.Range("B2").Resize(lastrow).Value)
vcol2 = WorksheetFunction.transpose(ws.Range("C2").Resize(lastrow).Value)
vcol3 = WorksheetFunction.transpose(ws.Range("D2").Resize(lastrow).Value)
vcol4 = WorksheetFunction.transpose(ws.Range("E2").Resize(lastrow).Value)
vcol5 = WorksheetFunction.transpose(ws.Range("F2").Resize(lastrow).Value)
vcol6 = WorksheetFunction.transpose(ws.Range("G2").Resize(lastrow).Value)

ws.Range("J2").Resize(1, UBound(vcol1)) = vcol1
ws.Range("J3").Resize(1, UBound(vcol1)) = vcol2
ws.Range("J4").Resize(1, UBound(vcol1)) = vcol3
ws.Range("J5").Resize(1, UBound(vcol1)) = vcol4
ws.Range("J6").Resize(1, UBound(vcol1)) = vcol5
ws.Range("J7").Resize(1, UBound(vcol1)) = vcol6

End Sub

Answer 1

經過測試：

Sub Pivot()
    Const NUM_MONTHS As Long = 3
    Const NUM_PROPS As Long = 3

    Dim rng As Range, rngDest As Range, arrProps, x

    'first block of source data
    Set rng = Sheets("Sheet1").Range("A2").Resize(NUM_MONTHS, 5)

    'header labels
    arrProps = Application.Transpose(rng.Rows(1).Offset(-1, 0). _
                              Cells(3).Resize(1, NUM_PROPS).Value)

    'top-left of destination table
    Set rngDest = Sheets("Sheet1").Range("J1")

    'set up headers
    With rngDest
        .Value = "Group"
        .Offset(0, 1).Value = "property"
        .Offset(0, 2).Resize(1, NUM_MONTHS).Value = _
                Application.Transpose(rng.Columns(2).Value)
    End With
    Set rngDest = rngDest.Offset(1, 0)

    'copy data
    Do While rng.Cells(1).Value <> ""
        rngDest.Value = rng.Cells(1, 1).Value 'group
        'property names
        rngDest.Offset(0, 1).Resize(NUM_PROPS, 1).Value = arrProps

        'property values
        For x = 1 To NUM_PROPS
            rngDest.Offset(x - 1, 2).Resize(1, NUM_MONTHS).Value = _
                Application.Transpose(rng.Columns(2 + x).Value)
        Next x

        'move to next block
        Set rng = rng.Offset(NUM_MONTHS, 0)
        Set rngDest = rngDest.Offset(3, 0)
    Loop
End Sub