VBA，改变树结构的格式
我有一个电子表格的格式如下所示。 我将如何能够将节点格式的格式更改为更可过滤的演示文稿
我现在有什么，从Col A开始，每个节点都在列和行之上
RootX |- Node1 |- Node1.1 |- Node1.1.1 |- Node1.1.1.1 - DataXYZ |- Node1.1.1.2 |- Node1.1.1.3 - DataABC |- Node1.2 |- Node1.2.1 |- Node1.2.1.1 |- Node2 |- Node2.1 |- Node2.1.1 |- Node2.1.1.1 RootY |- Node3 |- Node3.1 |- Node3.1.1 |- Node3.1.1.1 - DataHIJ |- Node3.1.2 |- Node3.1.2.1 预期结果：
Columns ABCDEF RootX Node1 Node1.1 Node1.1.1 Node1.1.1.1 DataXYZ RootX Node1 Node1.1 Node1.1.1 Node1.1.1.2 RootX Node1 Node1.1 Node1.1.1 Node1.1.1.3 DataABC RootX Node1 Node1.2 Node1.2.1 Node1.2.1.1 RootX Node2 Node2.1 Node2.1.1 Node2.1.1.1 RootY Node3 Node3.1 Node3.1.1 Node3.1.1.1 DataHIJ RootY Node3 Node3.1 Node3.1.2 Node3.1.2.1
编辑布鲁斯·韦恩
有时我会得到一个不应该一直填充的节点，也就是Node1.1.1.1.1（Col H可以这么说），那么当你在样本中填充它时，它就成为其余行的一部分。 例如，我不会在Col H中有另一个节点，所以这只会填满所有的方式。 任何工作？
通常，我会说提供一些更多的信息。 在你要找什么（因为有很多方法可以做到这一点）。 但是，我有两个macros，我认为它们将会在没有太多（如果有的话）的情况下进行编辑。 请注意，我很久以前写了这些（在我知道更好之前），所以他们不是很漂亮。
第一个会提示你select一个数据最多的行（得到一个lastRow），然后问你哪些列要复制数据。 在你的情况下，你想复制下来A，B，C，D和E（我认为E，如果它有“Node3.1.1.1 – DataHIJ”文本）。
Sub GEN_USE_Copy_Data_Down_MULTIPLE_Columns(Optional myColumns As Variant, Optional thelastRow As Variant) Dim yearCol As Integer, countryCol As Integer, commodityCol As Integer, screenRefresh As String, runAgain As String Dim lastRow As Long, newLastRow As Long Dim copyFrom As Range Dim c As Range Dim Cell As Range Dim SrchRng As Range Dim SrchStr As String Dim LastRowCounter As String Dim columnArray() As String Dim Column2Copy As String If Not IsMissing(myColumns) Then columnArray() = Split(myColumns) Else MsgBox ("Now, you will choose a column, and that column's data will be pasted in the range" & vbCrLf & "below the current cell, to the next full cell") Column2Copy = InputBox("What columns (A,B,C, etc.) would you like to copy the data of? Use SPACES, to separate columns") columnArray() = Split(Column2Copy) screenRefresh = MsgBox("Turn OFF screen updating while macro runs?", vbYesNo) If screenRefresh = vbYes Then Application.ScreenUpdating = False Else Application.ScreenUpdating = True End If End If Dim EffectiveDateCol As Integer If IsMissing(thelastRow) Then LastRowCounter = InputBox("What column has the most data (this info will be used to find the last used row") Else LastRowCounter = thelastRow lastRow = thelastRow End If CopyAgain: If IsMissing(thelastRow) Then With ActiveSheet lastRow = .Cells(.Rows.Count, LastRowCounter).End(xlUp).row 'lastRow = .UsedRange.Rows.Count End With End If Dim startCell As Range For i = LBound(columnArray) To UBound(columnArray) Debug.Print columnArray(i) & " is going to be copied now." Column2Copy = columnArray(i) Set startCell = Cells(1, Column2Copy).End(xlDown) Do While startCell.row < lastRow If startCell.End(xlDown).Offset(-1, 0).row > lastRow Then newLastRow = lastRow Else newLastRow = startCell.End(xlDown).Offset(-1, 0).row End If Set copyFrom = startCell Range(Cells(startCell.row, Column2Copy), Cells(newLastRow, Column2Copy)).Value = copyFrom.Value Set startCell = startCell.End(xlDown) Loop Next i If IsEmpty(myColumns) Then runAgain = MsgBox("Would you like to run the macro on another column?", vbYesNo) If runAgain = vbNo Then Cells(1, 1).Select Exit Sub ElseIf runAgain = vbYes Then GoTo CopyAgain End If End If MsgBox ("Done!") End Sub
然后，运行这一个，当find一个空白单元格时，select一个你想要删除的行。 我认为你应该能够使用列D（或者也许是E？）。
Sub GEN_USE_Delete_Entire_Row_based_on_Empty_Cell(Optional thelastRow As Variant, Optional iColumn As Variant) Dim yearCol As Integer, countryCol As Integer, commodityCol As Integer, screenRefresh As String Dim lastRow As Long, newLastRow As Long, LastRow2 As Long Dim copyFrom As Range Dim c As Range Dim Cell As Range Dim SrchRng As Range Dim SrchStr As String Dim LastRowCounter As String Dim i As Long Dim aRng As Range, cell1 As Range, cell2 As Range If IsMissing(thelastRow) Then screenRefresh = MsgBox("Turn OFF screen updating while macro runs?", vbYesNo) If screenRefresh = vbYes Then Application.ScreenUpdating = False Else Application.ScreenUpdating = True End If End If Dim EffectiveDateCol As Integer If IsMissing(thelastRow) Then LastRowCounter = InputBox("What column has the most data (this info will be used to find the last used row)") Else LastRowCounter = iColumn End If 'Note, you can use LastRow2 to also find the last row, without prompting the user...but note it uses ACTIVECELL LastRow2 = ActiveCell.SpecialCells(xlCellTypeLastCell).row CopyAgain: With ActiveSheet lastRow = .Cells(.Rows.Count, LastRowCounter).End(xlUp).row End With If IsMissing(iColumn) Then MsgBox ("Now, you will choose a column. Any cell in that column that is blank, will have that ENTIRE ROW deleted") End If Dim Column2DeleteRowsFrom As String If IsMissing(iColumn) Then Column2DeleteRowsFrom = InputBox("What column (A,B,C, etc.) would you like to delete entire row when a blank cell is found?") Else Column2DeleteRowsFrom = iColumn End If 'If there are headers, then stop deleting at row 2 Dim headerQ As Integer If IsMissing(iColumn) Then headerQ = MsgBox("Does the sheet have headers?", vbYesNo) If headerQ = vbYes Then headerQ = 2 Else headerQ = 1 End If Else headerQ = 2 End If Set cell1 = Cells(2, Column2DeleteRowsFrom) Set cell2 = Cells(lastRow, Column2DeleteRowsFrom) Set aRng = Range(cell1, cell2) Range(Cells(headerQ, Column2DeleteRowsFrom), Cells(lastRow, Column2DeleteRowsFrom)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete MsgBox ("Done removing blank cell rows!") End Sub
对，就像我说的，他们不是很漂亮。 我把它作为一个练习，让读者收紧/删除多余的东西。