# Thread: Divisions and Groupings (XP)

1. ## Divisions and Groupings (XP)

I have a challenge with divisions and groupings listed in a tree. Usually the child is listed before the parent thus my inquiry. What I would like to do is reshuffle the deck so that parent/child relationships make sense. I'm looking for a VBA solution for the reshuffle.

I have attached a sample workbook listing the child/parent relationships in Column A. Column E is what I would like to achieve. Known facts are the color of the divisions/groupings and bold text.

This one has me puzzled. I have tried numerous versions of code and only paint myself further into the corner.

John

2. ## Re: Divisions and Groupings (XP)

Did you just edit the text of your post, or have you also replaced the attachment?

3. ## Re: Divisions and Groupings (XP)

Try the following code:

Sub SortAll()
Dim m As Long
m = Cells(Rows.Count, 1).End(xlUp).Row
SortLevel 2, m
End Sub

Sub SortLevel(StartRow As Long, EndRow As Long)
Dim r As Long
Dim s As Long
Range(Cells(EndRow, 1), Cells(EndRow, 2)).Cut
Range(Cells(StartRow, 1), Cells(StartRow, 2)).Insert Shift:=xlShiftDown
r = EndRow
If Cells(r, 2) < 20 Then
Do
s = r - 1
Do While Cells(r, 2) < Cells(s, 2) And s > StartRow
s = s - 1
Loop
If s + 1 < r Then
SortLevel s + 1, r
End If
r = s
Loop Until r <= StartRow
End If
End Sub

Just an edit

5. ## Re: Divisions and Groupings (XP)

OK, I assumed that in my previous reply.

6. ## Re: Divisions and Groupings (XP)

Hans,

A brilliant solution.

Many thanks,
John

7. ## Re: Divisions and Groupings (XP)

Looking back I see that I left two superfluous lines in the code (if you look closely you'll notice that the indentation is not entirely consistent). Here is the code without those lines:

Sub SortAll()
Dim m As Long
m = Cells(Rows.Count, 1).End(xlUp).Row
SortLevel 2, m
End Sub

Sub SortLevel(StartRow As Long, EndRow As Long)
Dim r As Long
Dim s As Long
Range(Cells(EndRow, 1), Cells(EndRow, 2)).Cut
Range(Cells(StartRow, 1), Cells(StartRow, 2)).Insert Shift:=xlShiftDown
r = EndRow
Do
s = r - 1
Do While Cells(r, 2) < Cells(s, 2) And s > StartRow
s = s - 1
Loop
If s + 1 < r Then
SortLevel s + 1, r
End If
r = s
Loop Until r <= StartRow
End Sub

#### Posting Permissions

• You may not post new threads
• You may not post replies
• You may not post attachments
• You may not edit your posts
•