Want to avoid the missteps to gaining all the benefits of the cloud? Learn more about the different assessment options from our Cloud Advisory team.
Public Sub cmdSort_Click()
Dim wks As Worksheet
Dim wkb As Workbook
Dim rngToSort As Range
Dim keyRng As Range
Dim nextSort As Range
Dim helpSortCol As Range
Dim originalSort As Range
Set wkb = ThisWorkbook
Set wks = wkb.Sheets("Sheet1")
'Sort first section
wks.Sort.SortFields.Clear
Set rngToSort = wks.Range(wks.Range("A1"), wks.Range("A1").End(xlToRight).End(xlDown))
Set keyRng = Range(wks.Range("A1").End(xlToRight).Offset(1, 0), wks.Range("A1").End(xlToRight).Offset(1, 0).End(xlDown))
Set originalSort = wks.Range(wks.Range("A2"), wks.Range("A2").End(xlDown))
rngToSort.Sort Key1:=keyRng, Order1:=xlDescending, Header:=xlNo
'sort second, third, and any other subsequent sections
Set nextSort = wks.Range("A1").End(xlDown).End(xlDown) 'assumes next section separated by at least one blank line
While nextSort.row <> wks.Range("A" & wks.Rows.Count).row
Set nextSort = wks.Range(nextSort, nextSort.End(xlToRight).End(xlDown))
'create helper column from original sort
Set helpSortCol = nextSort.End(xlToRight).Offset(, 1).Resize(nextSort.Rows.Count)
helpSortCol.Cells(1, 1).Formula = "=MATCH(A" & helpSortCol.Cells(1, 1).row & "," & originalSort.Address & ",0)"
helpSortCol.FillDown
'now sort the section
Set rngToSort = Union(nextSort, helpSortCol) 'use the helper (last column) to sort
rngToSort.Sort Key1:=helpSortCol, Order1:=xlAscending, Header:=xlNo
'cleanup helpercolumn
helpSortCol.ClearContents
'setup for next sort, until done
Set nextSort = nextSort.End(xlDown).End(xlDown)
Wend
End Sub
See attached demo workbook.Public Sub cmdSort_Click()
Dim wks As Worksheet
Dim wkb As Workbook
Dim rngToSort As Range
Dim keyRng As Range
Dim nextSort As Range
Dim helpSortCol As Range
Dim originalSort As Range
Dim xCalc As Long
xCalc = Application.Calculation
Application.Calculation = xlCalculationAutomatic
Set wkb = ThisWorkbook
Set wks = wkb.Sheets("Sheet1")
'Sort first section
wks.Sort.SortFields.Clear
Set rngToSort = wks.Range(wks.Range("A1"), wks.Range("A1").End(xlToRight).End(xlDown))
Set keyRng = Range(wks.Range("A1").End(xlToRight).Offset(1, 0), wks.Range("A1").End(xlToRight).Offset(1, 0).End(xlDown))
Set originalSort = wks.Range(wks.Range("B2"), wks.Range("B2").End(xlDown)) ' sort by category
rngToSort.Sort Key1:=keyRng, Order1:=xlDescending, Header:=xlNo
'sort second, third, and any other subsequent sections
Set nextSort = wks.Range("A1").End(xlDown).End(xlDown) 'assumes next section separated by at least one blank line
While nextSort.row <> wks.Range("A" & wks.Rows.Count).row
Set nextSort = wks.Range(nextSort, nextSort.End(xlToRight).End(xlDown))
'create helper column from original sort
Set helpSortCol = nextSort.End(xlToRight).Offset(, 1).Resize(nextSort.Rows.Count)
helpSortCol.Cells(1, 1).Formula = "=MATCH(B" & helpSortCol.Cells(1, 1).row & "," & originalSort.Address & ",0)" 'sort by category
helpSortCol.FillDown
'now sort the section
Set rngToSort = Union(nextSort, helpSortCol) 'use the helper (last column) to sort
rngToSort.Sort Key1:=helpSortCol, Order1:=xlAscending, Header:=xlNo
'cleanup helpercolumn
helpSortCol.ClearContents
'setup for next sort, until done
Set nextSort = nextSort.End(xlDown).End(xlDown)
Wend
Application.Calculation = xCalc
End Sub
If you are experiencing a similar issue, please ask a related question
Join the community of 500,000 technology professionals and ask your questions.