自动创建组

Question

我正在尝试编写一个脚本来自动从SAP导出的数据创建组。因此，第一列中的数据如下所示，其中包含部件编号和描述。

.1
..2
..2
...3
....4
.1
.1
..2

依此类推，等等1为最高级别，4为最低原始级别，每个子级别可以有一个或数百个。只有一个出口有2,000-5,000个组件，所以这是一个非常繁琐的过程，从手动分组所有内容开始。所以我一直试图自动化这个，但一直碰壁。我的代码很乱，并没有真正做任何事情，但我会发布我已经完成的事情。

    Dim myRange As Range
    Dim rowCount As Integer, currentRow As Integer
    Dim GrpRange As Range, GrpStart As Integer, GrpEnd As Integer, GrpCount As Integer
    Dim GrpLoop As Integer, GrpLoopEnd As Integer, GrpLoopEndRow As Integer 
    Dim GrpSt As Integer

GrpSt = 2
GrpStart = 2
GrpEnd = RowEnd(2, 1)
GrpLoopEnd = 100

'Loop through each group
  'For TotalLoop = 2 To GrpEnd

'Determine 1 to 1 row length
For GrpStart = GrpSt To GrpEnd
    Cells(GrpStart, 1).Select
    If Right(ActiveCell, 1) = 1 Then
        GrpSt = ActiveCell.Row
        For GrpLoop = 0 To GrpLoopEnd
            If Right(Cells(GrpSt, 1), 1) = 1 Then
                GrpLoopEnd = 1
                GrpLoopEndRow = ActiveCell.Row
                Exit For
            End If
        Next
    End If

Next GrpStart

我首先只想找到每个顶级1和下一个顶级之间的长度，因为有时会有结构，有时却没有。接下来，我将对2然后3然后4在那个“组”中执行相同的操作，然后进行分组，最后循环遍历列的其余部分并执行与每个“1对1”组相同。我不确定这是正确的方式，还是可能，但我不得不从某个地方开始。

以下是导出内容的示例：

以下是我正在寻找的分组示例：

Answer 1

试试这段代码：

Sub AutoOutline_Characters()
Dim intIndent As Long, lRowLoop2 As Long, lRowStart As Long
Dim lLastRow As Long, lRowLoop As Long
Const sCharacter As String = "."

application.ScreenUpdating = False

Cells(1, 1).CurrentRegion.ClearOutline

lLastRow = Cells(Rows.Count, 1).End(xlUp).Row

With ActiveSheet.Outline
    .AutomaticStyles = False
    .SummaryRow = xlAbove
    .SummaryColumn = xlRight
End With

For lRowLoop = 2 To lLastRow

    intIndent = IndentCalc(Cells(lRowLoop, 1).Text, sCharacter)

    If IndentCalc(Cells(lRowLoop + 1, "A"), sCharacter) <= intIndent Then GoTo nxtCl:

    For lRowLoop2 = lRowLoop + 1 To lLastRow 'for all rows below our current cell

        If IndentCalc(Cells(lRowLoop2 + 1, "A"), sCharacter) <= intIndent And lRowLoop2 > lRowLoop + 1 Then 'if a higher dimension is encountered
            If lRowLoop2 > lRowLoop + 1 Then Rows(lRowLoop + 1 & ":" & lRowLoop2).Group
            GoTo nxtCl
        End If

    Next lRowLoop2

nxtCl:

Next lRowLoop

application.ScreenUpdating = True

End Sub

Function IndentCalc(sString As String, Optional sCharacter As String = " ") As Long
Dim lCharLoop As Long

For lCharLoop = 1 To Len(sString)
    If Mid(sString, lCharLoop, 1) <> sCharacter Then
        IndentCalc = lCharLoop - 1
        Exit Function
    End If
Next

End Function