0

我正在尝试编写一个脚本来自动从从 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和下一个顶层之间的长度，因为有时有结构，有时没有。接下来，我将在那个“组”中对2then 3then执行相同的4操作，然后进行分组，最后遍历列的其余部分，并对每个“1 对 1”组执行相同的操作。我不确定这是否正确甚至可能，但我必须从某个地方开始。

以下是导出内容的示例：

SO19009523 第一个问题示例

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

SO19009523 第二题示例

4

1 回答 1

0

试试这个代码：

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
于 2013-09-25T18:04:45.413 回答