这个问题困在我脑海里。无法抗拒解决它。首先,计算一行中的唯一值(节点+父节点)。在单元格N3中输入公式并填写它:=SUMPRODUCT(1/COUNTIF(B3:L3,B3:L3&""))
关于公式如何运作的详细信息:https://exceljet.net/formula/count-unique-values-in-a-range-with-countif
接下来,转到L15并为每个级别插入编号:1为父级,2 - 节点1,...,11 - 节点10。
在L17中输入公式并将其复制到整个范围B17:J25
=IF(L$15<=$N3,OFFSET($B3,0,$N3-L$15);"")
该公式以下列方式工作。它锚定每行的节点10值。根据行中有多少唯一值,它从左到右提取值。例如,如果Apple行(包括Parent)中有4个唯一值,则公式将仅从列B,C,D,E中提取值。
我可能缺乏描述这个过程的文字,看一下表:https://www.dropbox.com/s/n1y53v3nye3n47p/Transform%20Table.xlsx?dl=0
所以这是我为解决问题而编写的代码:
Sub MacroTest()
Dim iVal As Integer
Dim SearchValue As String
Dim WholeRange As String
Dim RangePart As String
Dim EndColumnToCut As Integer
Dim PasteCell As String
Application.ScreenUpdating = False 'Turn off window update while running macro
X = 3 'Row to start from
Y = 12 'Column Value where the table ends
Do Until IsEmpty(Cells(X, Y)) 'Start at Row X and loop through column Y
If IsError(ActiveSheet.Cells(X, Y)) Then 'Check if cell(X,Y) returns error code, if yes then skip current code
GoTo NextRow
Else
SearchValue = ActiveSheet.Cells(X, Y).Value 'Find the value in cell (X,Y)
iVal = Application.WorksheetFunction.CountIf(Range("B" & X, "L" & X), SearchValue) 'Count how many times the value in "SearchValue" appears (You want to remove duplicates and leave one unique value)
Cells_To_Remove = iVal - 1 'delete all cells with the same value except one
If Cells_To_Remove = 0 Then 'If "Cells_To_Remove" is equal to 0, i.e. there are no cells to remove, then go to next row
GoTo NextRow 'Skip cut and paste values and jump to next row
Else
RemoveValuesInRange = Range(Cells(X, Y - Cells_To_Remove + 1), Cells(X, Y)).ClearContents 'Clear Contents in the range
RemoveFormatInRange = Range(Cells(X, Y - Cells_To_Remove + 1), Cells(X, Y)).ClearFormats 'Clear formats in range
EndColumnToCut = Y - Cells_To_Remove 'Define the last column in range to cut data
RangePart = Range(Cells(X, 2), Cells(X, EndColumnToCut)).Select 'Define the whole range where the data should be cut
Selection.Cut 'Cut data
PasteCell = Cells(X, 2 + Cells_To_Remove).Select 'Define the cell where to paste the data
ActiveSheet.Paste 'Paste Data
End If
End If
GoTo NextRow 'Jump to next row
NextRow:
X = X + 1 'Jump to next row
Loop
End Sub