變換表結構

您好，有什么合理的演算法可以轉換資料表（表 A 到表 B）嗎？

我試圖移動單元格，但不知道如何計算我應該在我的關鍵欄位名稱之后放置額外行的位置。

表 A 原點

表 B（預期結果）

Sub TransformTable()

' Setting variables
Dim Name As String
Dim BaseSalary As String
Dim BonusName As String
Dim BonusAmount As Double

'Setting worksheet object
Dim SheetData As Worksheet
Set SheetData = Sheets("SheetData")

'counter for main loop
Dim x As Long

'Setting main object array
Dim MyArray As Variant

Dim Item As Integer
    Item = 1

'reading values from table
    MyArray = Worksheets("SheetData").ListObjects("Table1").DataBodyRange.Value

'counting last row value

'main loop
    For x = LBound(MyArray) To UBound(MyArray)

'condition check how many costcenter ids with fixed value
     lstRowSrs = SheetData.Cells(Rows.Count, 1).End(xlUp).Row
     Worksheets("SheetData").Cells(Item   1, 13).Value = MyArray(x, 1)
     Worksheets("SheetData").Cells(Item   1, 14).Value = MyArray(x, 2)
    
    If MyArray(x, 3) <> "" Then
     
    ' Cells(x, lstRowSrs).EntireRow.Insert
     
     Worksheets("SheetData").Cells(Item   2, 15).Value = MyArray(x, 3)
     Worksheets("SheetData").Cells(Item   2, 16).Value = MyArray(x, 4)
     Item = Item   1

    Else
     Worksheets("SheetData").Cells(Item   1, 15).Value = MyArray(x, 3)
     Worksheets("SheetData").Cells(Item   1, 16).Value = MyArray(x, 4)
      
      Item = Item   1
    End If
    Next x
 
End Sub 

uj5u.com熱心網友回復：

您可以使用Power QueryWindows Excel 2010 和 Office 365 Excel中的 獲得所需的輸出

• 在原始表格中選擇一些單元格
• Data => Get&Transform => From Table/Range
• 當 PQ UI 打開時，導航到Home => Advanced Editor
• 記下代碼第 2 行中的表名稱。
• 用下面的M代碼替換現有代碼
• 將粘貼代碼的第 2 行中的表名更改為您的“真實”表名
• 檢查任何評論和Applied Steps視窗，以更好地理解演算法和步驟

基本演算法：

• Unpivot Salary 和 Amount 列，將它們全部放在一個列中
• Bonus 列會有一些重復項——如果 Attribute 列包含“Salary”，則洗掉它們
• 洗掉 Salary 列的內容；重命名和重新排序列

M代碼

let

//change table name in next line to actual name in your workbook
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],

//set the data types
    #"Changed Type" = Table.TransformColumnTypes(Source,{
        {"Name", type text}, {"Salary", Int64.Type}, {"Bonus", type text}, {"Amount", Int64.Type}}),

//Unpivot the columns other than Name and Bonus
    #"Unpivoted Other Columns" = Table.UnpivotOtherColumns(#"Changed Type", {"Name", "Bonus"}, "Attribute", "Value"),

//blank the "bonus" if attribute=salary
    #"Replace Bonus with null" = Table.ReplaceValue(#"Unpivoted Other Columns", 
        each [Bonus],
        each if [Attribute]="Salary" then null else [Bonus],
        Replacer.ReplaceValue,{"Bonus"}),

//set columns in correct order
    #"Reordered Columns" = Table.ReorderColumns(#"Replace Bonus with null",{"Name", "Attribute", "Bonus", "Value"}),

//rename "Attribute"=>"Salary" and blank the contents
    Rename = Table.RenameColumns(#"Reordered Columns",{{"Attribute","Salary"},{"Value","Amount"}}),
    blankIt = Table.ReplaceValue(Rename, each [Salary],null, Replacer.ReplaceValue,{"Salary"})

in
    blankIt

uj5u.com熱心網友回復：

這是另一種方式。它與@Sgdva 具有相同的結果，但使用了一些略有不同的技術。不是更好，只是需要考慮。

Sub TransformTable()
    
    Dim vaValues As Variant
    Dim i As Long
    Dim aOutput() As Variant
    Dim lCnt As Long
    
    'put all the values in a 2-d array
    vaValues = Sheet1.ListObjects(1).DataBodyRange
    'make your output array - double the rows of the input
    'it will be too many rows, but you won't run out of room
    ReDim aOutput(1 To UBound(vaValues, 1) * 2, 1 To 4)
    
    'Loop through the 2-d array
    For i = LBound(vaValues, 1) To UBound(vaValues, 1)
        If Len(vaValues(i, 2)) > 0 Then 'a salary exists
            'add a row to the output array
            lCnt = lCnt   1
            aOutput(lCnt, 1) = vaValues(i, 1)
            aOutput(lCnt, 4) = vaValues(i, 2)
        End If
        
        If Len(vaValues(i, 4)) > 0 Then 'a bonus exists
            'add a row to the output array
            lCnt = lCnt   1
            aOutput(lCnt, 1) = vaValues(i, 1)
            aOutput(lCnt, 3) = vaValues(i, 3)
            aOutput(lCnt, 4) = vaValues(i, 4)
        End If
    Next i
    
    'write out the output array in one shot
    Sheet1.Range("G1").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput
    
End Sub

uj5u.com熱心網友回復：

解決方案
我將您發布的邏輯更改如下

1. 確定要添加的行
2. 一次插入（節省記憶體而不是一個一個插入）
3. 通過在行中再次回圈添加所需的資料

出于演示目的，我將邏輯限制為活動作業表并顯示了資料示例。 演示 代碼

Sub Exec_DivideSalary()
Dim CounterRow As Long
Dim RangeRowsToAdd As Range
    For CounterRow = 2 To Cells.SpecialCells(xlCellTypeLastCell).Row
    If Cells(CounterRow, 2).Value <> "" Then ' 1. If Cells(CounterRow, 2).Value <> ""
    If RangeRowsToAdd Is Nothing Then ' 2. If RangeRowsToAdd Is Nothing
    Set RangeRowsToAdd = Rows(CounterRow   1)
    Else ' 2. If RangeRowsToAdd Is Nothing
    Set RangeRowsToAdd = Union(RangeRowsToAdd, Rows(CounterRow   1))
    End If ' 2. If RangeRowsToAdd Is Nothing
    End If ' 1. If Cells(CounterRow, 2).Value <> ""
    Next CounterRow
    RangeRowsToAdd.Insert Shift:=xlDown
    For CounterRow = 2 To Cells.SpecialCells(xlCellTypeLastCell).Row
    If Cells(CounterRow, 2).Value <> "" Then ' 3. If Cells(CounterRow, 2).Value <> ""
    Cells(CounterRow   1, 1).Value = Cells(CounterRow, 1).Value: Cells(CounterRow   1, 3).Value = Cells(CounterRow, 3).Value: Cells(CounterRow   1, 4).Value = Cells(CounterRow, 4).Value
    Cells(CounterRow, 4).Value = Cells(CounterRow, 2).Value
    Cells(CounterRow, 2).Value = "": Cells(CounterRow, 3).Value = ""
    End If ' 3. If Cells(CounterRow, 2).Value <> ""
    Next CounterRow
End Sub

標籤：擅长 vba 算法

上一篇：一些模hijinkery

下一篇：ImageMagick：將AE失真除以fx輸出資訊格式的總像素