dkcoop03

asked on

I have part of a complex sort done. I'm attaching the spreadsheet and code so far. I basically need a 5 level sort. Categories with a minus "-" in front (col A) of them expand to contain sub categories -- they can also have a plus "+" in front of them indicating that they are rolled up. If there is a space " " in column A that indicates a category with no subcategories. I need to sort the sub categories within the categories and then sort every category against other categories. I have that part done. The complexity comes because there can be sub sub categories, or another level of category within the sub category. In that case I want those categories sorted within the sub category. So I somehow need to test both column A and column B for the +, - or space. So I'm wondering first, is my code the best way to do this (It does work for sub categories and categories) and second, how to incorporate the testing for sub sub categories. I'm using Excel 2010. Thanks

```
Private Sub cmdSort_Click()
Dim r As Range
Dim s As Range
Dim sign As Range
Dim lastrow As Integer
Dim catcount As Double
Dim catcount2 As Double
lastrow = Range("E3").End(xlDown).Row
catcount = lastrow
Set r = Range("G3")
Set s = Range("H3")
Set sign = Range("A3")
Set subsign = Range("B3")
While r.Row <= lastrow
If sign.Value <> "" Then
s.Formula = catcount + 0.1
r.Formula = r.Offset(0, -2).text
catcount2 = catcount
catcount = catcount - 1
Else 'populate cell with value in cell above
r.Formula = r.Offset(-1, 0).text
s.Formula = catcount2
End If
'drop down one row
Set s = s.Offset(1, 0)
Set r = r.Offset(1, 0)
Set sign = sign.Offset(1, 0)
Wend
Call FourKeySort
End Sub
Sub FourKeySort()
SortAll "H3"
SortAll "G3"
SortAll "J3"
SortAll "I3"
SortAll "E3"
End Sub
Sub SortAll(x As String)
Range(x).Sort _
Key1:=Range(x), _
Order1:=xlDescending, _
Header:=xlNo
End Sub
```

testsort.xlsx
Last Comment

I'm wondering why you can't use the builtin sort function and just add 5 levels?

ASKER

Because the boss wants the user to be able to click a button and have this sort automatically

could you use scenarios, i.e. use the built in sort facilities and then save it as a custom view.

create one view call 'normal', one called 'sorted' the user can then just choose which view they want.

How yo do that depends on version in 2007 it is view / custom view, in previous versions i think it was called scenarios, but i can't remember (sorry)

create one view call 'normal', one called 'sorted' the user can then just choose which view they want.

How yo do that depends on version in 2007 it is view / custom view, in previous versions i think it was called scenarios, but i can't remember (sorry)

ASKER

I don't think that's an option. Is this not doable in code?

ASKER

I guess when I asked if there was a better way to do this I meant a better way to code it

OK I think you have over complicated this.

i would fill the gaps

sort it (I have merely copied and pasted a recorded macro or the sorting so you will need to edit that code

'un' fill the gaps

as per this code...

Sub MyCode()

Dim y As Long

y = Cells(2, 5).End(xlDown).Row

FillGaps y

Sort

UnFillGaps y

End Sub

Sub FillGaps(yMax As Long)

yMax = Cells(2, 5).End(xlDown).Row

For y = 3 To yMax

If Cells(y, 2) = vbNullString Or Cells(y, 2) = "-" Then

Cells(y, 2) = Cells(y - 1, 2)

If Cells(y, 3) = vbNullString Then

Cells(y, 3) = Cells(y - 1, 3)

Else

Cells(y, 4) = "#"

End If

Else

If Cells(y, 3) = vbNullString Then

Cells(y, 3) = "#"

Cells(y, 4) = "#"

Else

Cells(y, 4) = "#"

Cells(y, 3) = Cells(y - 1, 3)

End If

End If

Next

End Sub

Sub Sort()

Range("B2:L26").Select

Application.CutCopyMode = False

ActiveWorkbook.Worksheets("Sheet3").Sort.SortFields.Clear

ActiveWorkbook.Worksheets("Sheet3").Sort.SortFields.Add Key:=Range("B3:B26") _

, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

ActiveWorkbook.Worksheets("Sheet3").Sort.SortFields.Add Key:=Range("C3:C26") _

, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

ActiveWorkbook.Worksheets("Sheet3").Sort.SortFields.Add Key:=Range("D3:D26") _

, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

With ActiveWorkbook.Worksheets("Sheet3").Sort

.SetRange Range("B2:L26")

.Header = xlYes

.MatchCase = False

.Orientation = xlTopToBottom

.SortMethod = xlPinYin

.Apply

End With

End Sub

Sub UnFillGaps(yMax As Long)

Dim y As Long

Dim cat1 As String

Dim cat2 As String

Cells(3, 1).Resize(yMax, 1).Clear

Selection.Replace What:="#", Replacement:=vbNullString, LookAt:=xlPart, _

SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

ReplaceFormat:=False

For y = 3 To yMax

If Cells(y, 2) = Cells(y - 1, 2) Or Cells(y, 2) = cat1 Then

If Cells(y, 3) = Cells(y - 1, 3) Or Cells(y, 3) = cat2 Then

cat2 = Cells(y, 3)

Cells(y, 2) = vbNullString

Cells(y, 3) = vbNullString

Else

If Cells(y, 3) = Cells(y + 1, 3) Then

Cells(y, 2) = "-"

Else

Cells(y, 2) = vbNullString

End If

End If

Else

cat1 = Cells(y, 2)

If Cells(y, 2) = Cells(y + 1, 2) Then

Cells(y, 1) = "-"

End If

End If

Next

End Sub

i would fill the gaps

sort it (I have merely copied and pasted a recorded macro or the sorting so you will need to edit that code

'un' fill the gaps

as per this code...

Sub MyCode()

Dim y As Long

y = Cells(2, 5).End(xlDown).Row

FillGaps y

Sort

UnFillGaps y

End Sub

Sub FillGaps(yMax As Long)

yMax = Cells(2, 5).End(xlDown).Row

For y = 3 To yMax

If Cells(y, 2) = vbNullString Or Cells(y, 2) = "-" Then

Cells(y, 2) = Cells(y - 1, 2)

If Cells(y, 3) = vbNullString Then

Cells(y, 3) = Cells(y - 1, 3)

Else

Cells(y, 4) = "#"

End If

Else

If Cells(y, 3) = vbNullString Then

Cells(y, 3) = "#"

Cells(y, 4) = "#"

Else

Cells(y, 4) = "#"

Cells(y, 3) = Cells(y - 1, 3)

End If

End If

Next

End Sub

Sub Sort()

Range("B2:L26").Select

Application.CutCopyMode = False

ActiveWorkbook.Worksheets(

ActiveWorkbook.Worksheets(

, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

ActiveWorkbook.Worksheets(

, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

ActiveWorkbook.Worksheets(

, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

With ActiveWorkbook.Worksheets(

.SetRange Range("B2:L26")

.Header = xlYes

.MatchCase = False

.Orientation = xlTopToBottom

.SortMethod = xlPinYin

.Apply

End With

End Sub

Sub UnFillGaps(yMax As Long)

Dim y As Long

Dim cat1 As String

Dim cat2 As String

Cells(3, 1).Resize(yMax, 1).Clear

Selection.Replace What:="#", Replacement:=vbNullString,

SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

ReplaceFormat:=False

For y = 3 To yMax

If Cells(y, 2) = Cells(y - 1, 2) Or Cells(y, 2) = cat1 Then

If Cells(y, 3) = Cells(y - 1, 3) Or Cells(y, 3) = cat2 Then

cat2 = Cells(y, 3)

Cells(y, 2) = vbNullString

Cells(y, 3) = vbNullString

Else

If Cells(y, 3) = Cells(y + 1, 3) Then

Cells(y, 2) = "-"

Else

Cells(y, 2) = vbNullString

End If

End If

Else

cat1 = Cells(y, 2)

If Cells(y, 2) = Cells(y + 1, 2) Then

Cells(y, 1) = "-"

End If

End If

Next

End Sub

oops sorry i should have put that in a code block

some extra comments, I ignored column A for sorting and just re-populated it when unfilling the rest.

i put # into blank cells because i knew it would sort before any cells with text in them.

so basically fill puts in a # of the value above

sort as i said is a recorded macro so you will need to 'fiddle' with the range selcetion

and unfill takes out all the #'s and then all the duplicated text putting - in where necessary

some extra comments, I ignored column A for sorting and just re-populated it when unfilling the rest.

i put # into blank cells because i knew it would sort before any cells with text in them.

so basically fill puts in a # of the value above

sort as i said is a recorded macro so you will need to 'fiddle' with the range selcetion

and unfill takes out all the #'s and then all the duplicated text putting - in where necessary

ASKER

This is a very interesting approach. It looks like you're sorting on Columns A,B & C though. I want to sort on column "Change" within each subsub category, and then within each sub category and and then within each category. I need to sort the CHANGE value within each category -- keeping the items together by category. And I also need to keep that sign with each category. I ran your code on the worksheet and it didn't appear to sort anything so I'm not sure what it's doing.

sorting columns BC&D,

clearing column A and then putting the -'s back where a category in column B has more than one row, like wise for column B if column C has sub categories.

try using F8 to step through the code

Excel's inbuilt sort will be much quicker than any VBA sort, so the idea is that by filling the gaps when Excel does the sorting it will automatically keep all the rows for each category, and sub category together.

The hard part was actually taking out all the extra bits i put in.

hmm if they were formatted (say red) then it would probably be easy to find all red cells and remove the contents, however you would still have to be careful especially putting the -'s back into column B

clearing column A and then putting the -'s back where a category in column B has more than one row, like wise for column B if column C has sub categories.

try using F8 to step through the code

Excel's inbuilt sort will be much quicker than any VBA sort, so the idea is that by filling the gaps when Excel does the sorting it will automatically keep all the rows for each category, and sub category together.

The hard part was actually taking out all the extra bits i put in.

hmm if they were formatted (say red) then it would probably be easy to find all red cells and remove the contents, however you would still have to be careful especially putting the -'s back into column B

View this solution by signing up for a free trial.

Members can start a 7-Day free trial and enjoy unlimited access to the platform.

ASKER

I ended up using some math logic to keep all of the categories together and then just concatenated fields and sorted on the concatenated field. Sorry it took so long to get back to you but I am just now getting back to this.

Microsoft Excel

Microsoft Excel topics include formulas, formatting, VBA macros and user-defined functions, and everything else related to the spreadsheet user interface, including error messages.

144K

Questions

--

Followers

--

Top Experts

Get a personalized solution from industry experts

TRUSTED BY