如何像 Power Query 一样使用 VBA 取消固定数量的列

Posted 2023-04-12

【中文标题】如何像 Power Query 一样使用 VBA 取消固定数量的列

【英文标题】：How to unpivot a Fixed number of columns with VBA just like Power Query

【发布时间】：2020-10-30 20:33:07

【问题描述】：

例如，我有 130 列，其中 13 列必须是 Unpivoted。

行数不时变化。

这适用于 Power Query。

我附上了一个示例文件来展示我的数据是如何呈现的，

A 到 E 列是固定数组，F 往前是要反透视的列。

我发现 PowerQuery 也可以使用 VBA。我在这里遇到错误：

Sub Macro10()

    ActiveWorkbook.Queries.Add Name:="ProjectDetails (4)", Formula:= _
        "let" & Chr(13) & "" & Chr(10) & "    Source = Excel.CurrentWorkbook()[Name=""ProjectDetails""][Content]," & Chr(13) & "" & Chr(10) & "    #""Changed Type"" = Table.TransformColumnTypes(Source,""Project"", Int64.Type, ""Project2"", Int64.Type, ""Project Name"", type text, ""Strategic Business Unit"", type text, ""Area"", type text, ""Sub Area"", type text, ""Business Line"", type text, ""Department"", ty" & _
        "pe text, ""AECOM Project Review Category"", type text, ""Customer Name"", type text, ""Customer Type"", type text, ""Project Manager"", type text, ""Project Accountant"", type text, ""Project Biller"", type text, ""Regional Director"", type text, ""Project Director"", type text, ""Project Status"", type text, ""End-Client Sector"", type text, " & _
        """Global Business Line"", type text, ""AECOM Work"", type text, ""AECOM Funding Source"", type text, ""Distribution Rule"", type text, ""Agreement"", type text, ""CRM Tracking #"", type text, ""Last Invoiced Date"", type any, ""Last EAC Date"", type any, ""Scheduled Start Date"", type datetime, ""Scheduled Finish Date"", type datetime, ""Forecast" & _
        " End Date"", type datetime, ""AECOM Contract Type"", type text, ""MTD Revenue"", type number, ""MTD Total Costs"", type number, ""MTD DL"", type number, ""MTD Fringe"", type number, ""MTD Overhead"", type number, ""MTD ODC"", type number, ""MTD Subs"", type number, ""NSR MTD"", type number, ""MTD GM"", type number, ""MTD GM % of Revenues"", typ" & _
        "e number, ""MTD NM"", type number, ""Direct Labor Multiplier MTD"", type number, ""Salary Cost Multiplier MTD"", type number, ""MTD Bookings"", type number, ""YTD Revenue"", type number, ""YTD Total Costs"", type number, ""YTD DL"", type number, ""YTD Fringe"", type number, ""YTD Overhead"", type number, ""YTD ODC"", type number, ""YTD Subs"", " & _
        "type number, ""YTD NSR"", type number, ""YTD GM"", type number, ""YTD GM % of Revenue"", type number, ""YTD NM"", type number, ""YTD DLM"", type number, ""YTD SCM"", type number, ""YTD Bookings"", type number, ""ITD Revenue"", type number, ""ITD Total Costs"", type number, ""ITD DL"", type number, ""ITD Fringe"", type number, ""ITD Overhead""" & _
        ", type number, ""ITD ODC"", type number, ""ITD Subs"", type number, ""ITD NSR"", type number, ""ITD GM"", type number, ""ITD GM% of Revenue"", type number, ""ITD NM"", type number, ""ITD DLM"", type number, ""ITD SCM"", type number, ""Funded Value"", type number, ""Backlog"", type number, ""Unbilled >30"", type number, ""Unbilled (BIEE)"", ty" & _
        "pe number, ""ITD Billed"", type number, ""Billing > 60"", type number, ""Trade AR"", type number, ""Retention"", Int64.Type, ""Appr Revenue Budget"", type number, ""Appr ODC Budget"", type number, ""Appr Subs Budget"", type number, ""Appr Contingency Budget"", type number, ""Appr DL Budget"", type number, ""Appr Fringe Budget"", type number, """ & _
        "Appr Cost Budget"", type number, ""Appr DLM Budget"", type number, ""Appr SCM Budget"", type number, ""Frcst Revenue Budget"", type number, ""Frcst ODC Budget"", type number, ""Frcst Subs Budget"", type number, ""Frcst Contingency Budget"", type number, ""Frcst DL Budget"", type number, ""Frcst Fringe Budget"", type number, ""Frcst Overhead Budget" & _
        """, type number, ""Frcst Cost Budget"", type number, ""Frcst DLM"", type number, ""Frcst SCM"", type number, ""Source System Description"", type text, ""Source System ID"", Int64.Type, ""Valid for Review?"", type text, ""Project Accountant Required"", type text, ""Invoiced Over Contract "", type number, ""Est. Collections over Contact "", type numb" & _
        "er, ""Current ETC "", type number, ""Trended Costs"", Int64.Type, ""Est. ETC at Month End"", type number, ""MTD NM% of NSR"", type any, ""YTD NM% of NSR"", type any, ""ITD NM% of NSR"", type any, ""Percent Complete"", type any, ""Backlog Burn Rate"", type any, ""Billing Backlog"", type number, ""Unbilled Reserve"", type number, ""AR Reserve"", " & _
        "type number, ""YTD Lost Margin"", type number, ""Project Manager Location"", type text, ""ROCV"", type text, ""Low to Zero Backlog"", type text, ""Negative Margin MTD"", type text, ""Negative Margin YTD"", type text, ""Negative Margin ITD"", type text)," & Chr(13) & "" & Chr(10) & "    #""Unpivoted Columns"" = Table.UnpivotOtherColumns(#""Changed Type"", ""Project"", ""Project" & _
        "2"", ""Project Name"", ""Strategic Business Unit"", ""Area"", ""Sub Area"", ""Business Line"", ""Department"", ""AECOM Project Review Category"", ""Customer Name"", ""Customer Type"", ""Project Manager"", ""Project Accountant"", ""Project Biller"", ""Regional Director"", ""Project Director"", ""Project Status"", ""End-Client Sector"", ""Global Business Line"", ""AEC" & _
        "OM Work"", ""AECOM Funding Source"", ""Distribution Rule"", ""Agreement"", ""CRM Tracking #"", ""Last Invoiced Date"", ""Last EAC Date"", ""Scheduled Start Date"", ""Scheduled Finish Date"", ""Forecast End Date"", ""AECOM Contract Type"", ""MTD Revenue"", ""MTD Total Costs"", ""MTD DL"", ""MTD Fringe"", ""MTD Overhead"", ""MTD ODC"", ""MTD Subs"", ""NSR MTD"", ""MTD" & _
        " GM"", ""MTD GM % of Revenues"", ""MTD NM"", ""Direct Labor Multiplier MTD"", ""Salary Cost Multiplier MTD"", ""MTD Bookings"", ""YTD Revenue"", ""YTD Total Costs"", ""YTD DL"", ""YTD Fringe"", ""YTD Overhead"", ""YTD ODC"", ""YTD Subs"", ""YTD NSR"", ""YTD GM"", ""YTD GM % of Revenue"", ""YTD NM"", ""YTD DLM"", ""YTD SCM"", ""YTD Bookings"", ""ITD Revenue"", ""ITD " & _
        "Total Costs"", ""ITD DL"", ""ITD Fringe"", ""ITD Overhead"", ""ITD ODC"", ""ITD Subs"", ""ITD NSR"", ""ITD GM"", ""ITD GM% of Revenue"", ""ITD NM"", ""ITD DLM"", ""ITD SCM"", ""Funded Value"", ""Backlog"", ""Unbilled >30"", ""Unbilled (BIEE)"", ""ITD Billed"", ""Billing > 60"", ""Trade AR"", ""Retention"", ""Appr Revenue Budget"", ""Appr ODC Budget"", ""Appr Subs Bu" & _
        "dget"", ""Appr Contingency Budget"", ""Appr DL Budget"", ""Appr Fringe Budget"", ""Appr Cost Budget"", ""Appr DLM Budget"", ""Appr SCM Budget"", ""Frcst Revenue Budget"", ""Frcst ODC Budget"", ""Frcst Subs Budget"", ""Frcst Contingency Budget"", ""Frcst DL Budget"", ""Frcst Fringe Budget"", ""Frcst Overhead Budget"", ""Frcst Cost Budget"", ""Frcst DLM"", ""Frcst SCM" & _
        """, ""Source System Description"", ""Source System ID"", ""Valid for Review?"", ""Project Accountant Required"", ""Invoiced Over Contract "", ""Est. Collections over Contact "", ""Current ETC "", ""Trended Costs"", ""Est. ETC at Month End"", ""MTD NM% of NSR"", ""YTD NM% of NSR"", ""ITD NM% of NSR"", ""Percent Complete"", ""Backlog Burn Rate"", ""Billing Backlog"", " & _
        """Unbilled Reserve"", ""AR Reserve"", ""YTD Lost Margin"", ""Project Manager Location"", ""Attribute"", ""Value"")" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & "    #""Unpivoted Columns"""
    ActiveWorkbook.Worksheets.Add
    With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
        "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=""ProjectDetails (4)"";Extended Properties=""""" _
        , Destination:=Range("$A$1")).QueryTable
        .CommandType = xlCmdSql
        .CommandText = Array("SELECT * FROM [ProjectDetails (4)]")
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .ListObject.DisplayName = "ProjectDetails__4"
        .Refresh BackgroundQuery:=False
    End With
    Application.CommandBars("Queries and Connections").Visible = False
End Sub

【问题讨论】：

VBA 确实做电源查询。

真的吗？我试图做录音，但它没有通过。然后我将在这里复制我的宏录制。我也在尝试搜索一个使用 pq 的宏，但不是一个位。 :(

Here's one macro for example.

VBA 示例：***.com/questions/36365839/…

谢谢@TimWilliams 先生。我已经检查了它并用我的数据进行了尝试。这里只有两个问题，我真的很抱歉我对此一无所知，因为我在这个领域非常陌生。对不起。但这是我的问题： 1）它不会取消旋转列标题，它应该标记每一行的值。 2) 我可以在哪里修改固定列的数量和位置，以及要取消透视的列的位置和数量。 再次感谢您的伟大，先生，但再次希望您能原谅我的无知。

【参考方案1】：

在我发布的链接中没有更改 UnPivotData 函数，这应该可以根据您发布的文件执行您想要的操作：

Sub Tester()

    Dim p

    'get the unpivoted data as a 2-D array
    p = UnPivotData(ThisWorkbook.Sheets("data source").Range("A2").CurrentRegion, _
                  118, True, True)
    
    'I added a new sheet for the output
    With Sheets("output2")
        .Cells.ClearContents
        .Range("A1").Resize(UBound(p, 1), UBound(p, 2)).Value = p 'populate array to sheet
    End With

    'EDIT: alternative (slower) method to populate the sheet
    '      from the pivoted dataset.  Might need to use this
    '      if you have a large amount of data
'    Dim r As Long, c As Long
'    For r = 1 To UBound(p, 1)
'    For c = 1 To UBound(p, 2)
'        Sheets("Sheet2").Cells(r, c).Value = p(r, c)
'    Next c
'    Next r

End Sub

编辑 - 添加UnPivotData 函数：

Function UnPivotData(rngSrc As Range, fixedCols As Long, _
                   Optional AddCategoryColumn As Boolean = True, _
                   Optional IncludeBlanks As Boolean = True)

    Dim nR As Long, nC As Long, data, dOut()
    Dim r As Long, c As Long, rOut As Long, cOut As Long, cat As Long
    Dim outRows As Long, outCols As Long
    
    data = rngSrc.Value 'get the whole table as a 2-D array
    nR = UBound(data, 1) 'how many rows
    nC = UBound(data, 2) 'how many cols

    'calculate the size of the final unpivoted table
    outRows = nR * (nC - fixedCols)
    outCols = fixedCols + IIf(AddCategoryColumn, 2, 1)
    
    'resize the output array
    ReDim dOut(1 To outRows, 1 To outCols)
               
    'populate the header row
    For c = 1 To fixedCols
        dOut(1, c) = data(1, c)
    Next c
    If AddCategoryColumn Then
        dOut(1, fixedCols + 1) = "Category"
        dOut(1, fixedCols + 2) = "Value"
    Else
        dOut(1, fixedCols + 1) = "Value"
    End If
    
    'populate the data
    rOut = 1
    For r = 2 To nR
        For cat = fixedCols + 1 To nC
            
            If IncludeBlanks Or Len(data(r, cat)) > 0 Then
                rOut = rOut + 1
                'Fixed columns...
                For c = 1 To fixedCols
                    dOut(rOut, c) = data(r, c)
                Next c
                'populate unpivoted values
                If AddCategoryColumn Then
                    dOut(rOut, fixedCols + 1) = data(1, cat)
                    dOut(rOut, fixedCols + 2) = data(r, cat)
                Else
                    dOut(rOut, fixedCols + 1) = data(r, cat)
                End If
            End If

        Next cat
    Next r
    
    UnPivotData = dOut
End Function

【讨论】：

天哪，先生，它成功了！！！这太棒了。我很感激！不太熟悉这个论坛的运作方式，所以请告诉我如何回报您！

您需要做的就是点击旁边的复选标记接受答案。