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

I have a situation where I have multiple groups of matrix that I would like to transpose and would like some help with Excel vba code. Thank you in advance for your help.

我有一种情况,我有多组矩阵,我想转置,并希望得到一些Excel vba代码的帮助。预先感谢您的帮助。

My table is as follows-(it will be 13 month view but I'm showing only 3 for this sample)

我的表格如下 - (这将是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

and so on (more groups and more months) Desired result---

等等(更多团体和更多月份)期望的结果---

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

and so on (with their values transposed)

依此类推(换算值)

sample code not exactly giving the above result but something I have used to start with.

示例代码并不完全给出上述结果,而是我过去常用的东西。

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

1 个解决方案

#1

Tested:

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