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

使用Excel vba转置重复的矩阵范围

1 个答案: