'Automating group creation
I'm trying to write a script to automate creating groups from data being exported from SAP. So the data comes out as follows in the first column with part numbers and descriptions in the following ones.
.1
..2
..2
...3
....4
.1
.1
..2
and so on and so forth with 1 being the highest level and 4 the lowest raw material level there can be one of each or hundreds of each sub-level. Just one export has 2,000-5,000 components so it's a very tedious process starting out with grouping everything manually. So I've been trying to automate this but keep running into walls. My code is a mess and doesn't really do anything but I'll post what I've done.
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
I'm first just trying to find the length between each top level 1 and the next one, because sometimes there is structure and sometimes not. Next I was going to do the same for the 2 then 3 then 4 within that one "group", then do the grouping and finally loop through the rest of the column and do the same with each "1 to 1" group. I'm not sure if this is the right way or even possible but I had to start from somewhere.
Here's an example of what is exported:

Here's an example of the grouping I'm looking for:

Solution 1:[1]
Try this code:
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
Solution 2:[2]
To group in several levels we need a row variable for each level, which marks the beginning of each group (r1, r2, r3, r4,...), plus a variable "r" to go through all the rows only once:
DIM r, r1, r2, r3... As Long
For r=1 to maxRow
If r1=0 And condition1(r) Then r1 = r
If r2=0 And condition2(r) Then r2 = r
If r3=0 And condition3(r) Then r3 = r
...
'Level 3:
If r3 <> 0 And condition3(r) then
Rows(r3 & ":" & r).Group
r3= 0
End If
'Level 2:
If r2 <> 0 And condition2(r) then
Rows(r2 & ":" & r).Group
r2 = 0
End If
'Level 1:
If r1 <> 0 And condition1(r) then
Rows(r1 & ":" & r).Group
r1 = 0
End If
...
Next
Sources
This article follows the attribution requirements of Stack Overflow and is licensed under CC BY-SA 3.0.
Source: Stack Overflow
| Solution | Source |
|---|---|
| Solution 1 | nutsch |
| Solution 2 | Uno Buscando |
