VBA编码 - 像Power Query这样的Unpivot数据[重复]

Posted 2023-04-12

【中文标题】VBA编码 - 像Power Query这样的Unpivot数据[重复]

【英文标题】：VBA coding - Unpivot Data like Power Query [duplicate]

【发布时间】：2021-02-03 23:37:57

【问题描述】：

我需要使用 VBA 代码来取消透视/反转像数据库这样的表。我今天有几个月的列，但我只需要一个包含所有月份的列（如数据库）。

我知道我们可以使用 Power 查询，但我需要使用 VBA

请看图片了解：

第一张图片：表中的原始数据：我需要将表还原（转换）到数据库中

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

感谢您的帮助

【问题讨论】：

***.com/questions/36365839/…

【参考方案1】：

对于 VBA 解决方案

通过将数据读入字典对象来组织数据 关键是区域 该项目将是一个类对象，其中包含月份和值的字典 实际上并不需要一个类，但如果扩展您对数据所做的工作可能会派上用场

重要说明和解释请阅读代码中的注释和cmets。

假设您将月份延长至 12 个月，您需要移动结果范围。我会建议一个不同的工作表。

如果您有多年的数据，则需要更改收集和组织输出的方式。例如：如果您要向一个地区添加多个 Jan。正如所写的那样，代码将返回一条错误消息，并且不允许您这样做。如果您决定要执行其他操作，则需要确定具体内容，然后编辑代码。

类模块

'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

【参考方案2】：

如果您对非 VBA 解决方案感兴趣，以下适用于支持 LET 和动态数组的 Excel Office 365。

=LET(data,B2:G5,
     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,

     CHOOSE(1,2,3, INDEX(rowHeaders,rowIndex), INDEX(colHeaders,colIndex), INDEX(data,rowIndex,colIndex)))