excel - VBA 编码 - 像 Power Query 这样的反透视数据

Question

这个问题在这里已经有了答案:





Transpose multiple columns to multiple rows with VBA

(4 个回答)


去年关闭。




我需要使用 VBA 代码来取消透视/反转像数据库这样的表。我今天有几个月的专栏，但我只需要一个包含所有月份的专栏(如数据库)。
我知道我们可以使用 Power 查询来做到这一点，但我需要使用 VBA
请查看图片以了解:
第一张图片:表中的原始数据:我需要将表还原(转换)为数据库

第二张图片:新数据库:unpivot 后的最终数据库

谢谢你的帮助

Answer 1

对于 VBA 解决方案

通过将数据读入字典对象来组织数据

关键将是区域

该项目将是一个类对象，其中包含月份和值的字典

并不真的需要一个类，但如果扩展您对数据所做的工作可能会派上用场

请阅读代码中的注释和注释以获取重要说明和解释。
假设您将月份延长至 12 个月，您将需要移动结果范围。我会建议一个不同的工作表。
如果您有多年的数据，则需要更改收集和组织输出的方式。例如:如果您要向一个地区添加多个 Jan。正如所写的那样，代码将返回一条错误消息，并且不允许您这样做。如果您决定要执行其他操作，则需要确定具体内容，然后编辑代码。
类(class)模块

'Change name of module to Region
'Region will be the key
'Set reference to Microsoft Scripting Runtime
Option Explicit
Private pMnth As String
Private pMnths As Dictionary
Private pAmt As Long 'or Double if decimals will be needed

Public Property Get Mnth() As String
    Mnth = pMnth
End Property
Public Property Let Mnth(Value As String)
    pMnth = Value
End Property

Public Property Get Mnths() As Dictionary
    Set Mnths = pMnths
End Property
Public Function addMnthsItem(sKey)
    'shouldn't really need this unless data covers multiple years
    If pMnths.Exists(sKey) Then
        MsgBox "Duplicate key will not be added"
    Else
        pMnths.Add Key:=sKey, Item:=pAmt
    End If
End Function

Public Property Get Amt() As Long
    Amt = pAmt
End Property
Public Property Let Amt(Value As Long)
    pAmt = Value
End Property

Private Sub Class_Initialize()
    Set pMnths = New Dictionary
        pMnths.CompareMode = TextCompare
End Sub

常规模块

'Set reference to Microsoft Scripting Runtime
Option Explicit
Sub unPivotRegion()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim dR As Dictionary, cR As cRegion
    Dim I As Long, J As Long, lastRow As Long, lastCol As Long, sKey As String
    Dim numRows As Long
    Dim v, w
    
'Set the source and results worksheets and ranges
Set wsSrc = Worksheets("Sheet4")
Set wsRes = Worksheets("Sheet4") 'or use a different worksheet
    Set rRes = wsRes.Cells(1, 10) 'or something else. just don't overlap with Src
    
'read source data into vba array for fastest processing
With wsSrc
    lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    lastCol = .Cells(1, 1).End(xlToRight).Column
    vSrc = Range(.Cells(1, 1), .Cells(lastRow, lastCol))
End With

'read and organize into dictionary
Set dR = New Dictionary
    dR.CompareMode = TextCompare
    
For I = 2 To UBound(vSrc, 1)
    Set cR = New cRegion
    sKey = vSrc(I, 1)
    For J = 2 To UBound(vSrc, 2)
        With cR
            .Amt = vSrc(I, J)
            .Mnth = vSrc(1, J)
            If Not dR.Exists(sKey) Then
                .addMnthsItem (.Mnth)
                dR.Add Key:=sKey, Item:=cR
            Else
                dR(sKey).addMnthsItem (.Mnth)
            End If
        End With
    Next J
Next I

'Output in a vertical array
'Calc num of rows
numRows = 0
For Each v In dR.Keys
    numRows = numRows + dR(v).Mnths.Count
Next v

ReDim vRes(0 To numRows, 1 To 3)

'Headers
vRes(0, 1) = "Region"
vRes(0, 2) = "Month"
vRes(0, 3) = "Amount"

'populate the array
I = 0
For Each v In dR.Keys
    For Each w In dR(v).Mnths
        I = I + 1
        vRes(I, 1) = v
        vRes(I, 2) = w
        vRes(I, 3) = dR(v).Mnths(w)
    Next w
Next v
    
'write the results to the worksheet
Application.ScreenUpdating = False
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    .EntireColumn.AutoFit
    .Style = "Output" 'may need to alter depending on environment and desires
End With

End Sub