Complicated sort using VBA

M

MrOllyR

New Member
Joined
Jun 24, 2020
Messages
24
Office Version
  1. 365
Platform
  1. Windows
Hi, everyone

I'm trying to automate a sort function using VBA. I'm looking at student scores and I'm trying to create class groups based on scores while keeping ages within 4 years.

Here's the spreadsheet: Sort range.xlsm
It's a link to Google Drive as I'm using a work computer:

I have managed to create the initial sort in this order: Grade 4, Grade 3, Grade 2, Grade 1. The macro includes whole columns as I want to be able to use it with different data sets:

Sub Sort()

Columns("A:H").Select
ActiveWorkbook.Worksheets("Data").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Data").Sort.SortFields.Add2 Key:=Range("H:H") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Data").Sort.SortFields.Add2 Key:=Range("G:G") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Data").Sort.SortFields.Add2 Key:=Range("F:F") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Data").Sort.SortFields.Add2 Key:=Range("E:E") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Data").Sort
.SetRange Range("A:H")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub

From here, I want to find the lowest number in column H and find the next half number in column H, e.g. if the first number in column H is "0.5" the next number would be "1.". In this instance, the lowest number is "0" and the next number is "0.5".

Grade 4.png


With the data range A2:H10 (everyone in this range has a score in column H of "0" to "0.5"), I would like to sort this data by: Age, Grade 4, Grade 3, Grade 2, and Grade 1.

From then I want to repeat the process above but starting from the next row. In this instance it's students with a score in column H with "1" to "1.5". This would be range A11:A24. Again, I would like to sort this data by: Age, Grade 4, Grade 3, Grade 2, and Grade 1.

I want it to repeat this process through the rest of the data, sorting by Age, Grade 4, Grade 3, Grade 2, and Grade 1.

Can anyone help?

Thank you in advance.
 

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.
Sort by date Sort by votes
VBA Code: 
Sub Sort()
     Dim c     As Range
     With Sheets("Data")
          Set c0 = .Range("a1").CurrentRegion
          c0.AutoFilter
          If c0.Rows.Count <= 1 Then MsgBox "sorry...": Exit Sub
          With .Sort
               .SortFields.Clear
               .SortFields.Add2 Key:=c0.Columns("H"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
               .SortFields.Add2 Key:=c0.Columns("G"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
               .SortFields.Add2 Key:=c0.Columns("F"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
               .SortFields.Add2 Key:=c0.Columns("E"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
               .SetRange c0
               .Header = xlYes
               .MatchCase = False
               .Orientation = xlTopToBottom
               .SortMethod = xlPinYin
               .Apply
          End With

          mymin = Application.Min(c0.Columns("H"))
          mymax = Application.Max(c0.Columns("H").Value)
          For i = mymin To mymax
               c0.AutoFilter 8, ">=" & i, xlAnd, "<" & i + 1
               On Error Resume Next
               Set c = Intersect(c0.Offset(1), c0.SpecialCells(xlVisible))
               On Error GoTo 0
               If Not c Is Nothing Then
                    MsgBox c.Address
                    With .Sort
                         .SortFields.Clear
                         .SortFields.Add2 Key:=c.Columns("C"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                         .SortFields.Add2 Key:=c.Columns("H"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                         .SortFields.Add2 Key:=c.Columns("G"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                         .SortFields.Add2 Key:=c.Columns("F"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                         .SortFields.Add2 Key:=c.Columns("E"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                         .SetRange c
                         .Header = xlNo
                         .MatchCase = False
                         .Orientation = xlTopToBottom
                         .SortMethod = xlPinYin
                         .Apply
                    End With
               End If
          Next
          c0.AutoFilter
     End With
End Sub
 
Upvote 0
Solution
BSALV said:
VBA Code: 
Sub Sort()
     Dim c     As Range
     With Sheets("Data")
          Set c0 = .Range("a1").CurrentRegion
          c0.AutoFilter
          If c0.Rows.Count <= 1 Then MsgBox "sorry...": Exit Sub
          With .Sort
               .SortFields.Clear
               .SortFields.Add2 Key:=c0.Columns("H"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
               .SortFields.Add2 Key:=c0.Columns("G"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
               .SortFields.Add2 Key:=c0.Columns("F"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
               .SortFields.Add2 Key:=c0.Columns("E"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
               .SetRange c0
               .Header = xlYes
               .MatchCase = False
               .Orientation = xlTopToBottom
               .SortMethod = xlPinYin
               .Apply
          End With

          mymin = Application.Min(c0.Columns("H"))
          mymax = Application.Max(c0.Columns("H").Value)
          For i = mymin To mymax
               c0.AutoFilter 8, ">=" & i, xlAnd, "<" & i + 1
               On Error Resume Next
               Set c = Intersect(c0.Offset(1), c0.SpecialCells(xlVisible))
               On Error GoTo 0
               If Not c Is Nothing Then
                    MsgBox c.Address
                    With .Sort
                         .SortFields.Clear
                         .SortFields.Add2 Key:=c.Columns("C"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                         .SortFields.Add2 Key:=c.Columns("H"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                         .SortFields.Add2 Key:=c.Columns("G"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                         .SortFields.Add2 Key:=c.Columns("F"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                         .SortFields.Add2 Key:=c.Columns("E"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                         .SetRange c
                         .Header = xlNo
                         .MatchCase = False
                         .Orientation = xlTopToBottom
                         .SortMethod = xlPinYin
                         .Apply
                    End With
               End If
          Next
          c0.AutoFilter
     End With
End Sub
Click to expand...
Thank you, this is much appreciated! If I wanted to restrict the parameters in column H- at the moment it's set to 1, i.e. sort grades 0-0.5; grades 1-1.5, etc.
Would I change this: c0.AutoFilter 8, ">=" & i, xlAnd, "<" & i + 1
If I change the last number to 0.5, would that narrow the parameters?
 
Upvote 0
i suppose the points are multiples of 0.5, there 'll be nothing like a 0.3 ???
Then you can use a step of 0.5 in the for...next loop and an exact match
Rich (BB code): 
For i = mymin To mymax step 0.5
               c0.AutoFilter 8, "=" & i
 
Upvote 0
BSALV said:
i suppose the points are multiples of 0.5, there 'll be nothing like a 0.3 ???
Then you can use a step of 0.5 in the for...next loop and an exact match
Rich (BB code): 
For i = mymin To mymax step 0.5
               c0.AutoFilter 8, "=" & i
Click to expand...
Thank you!
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Solved
VBA - button to sort by date in ascending and descending order
Replies
6
Views
375
Peter_SSs
Peter_SSs
Dazzawm
  • Solved
Slight Amendment To Code
Replies
6
Views
292
Dazzawm
Dazzawm
SandsB
  • Question
Sorting when a column or 2 is empty
Replies
1
Views
157
DanteAmor
DanteAmor
H
  • Solved
Column sort
Replies
9
Views
106
Fluff
Fluff
O
  • Solved
VBA: Deleting Visible rows using Auto Filter; Excluding Header
Replies
4
Views
384
mumps
mumps

Forum statistics

Threads
1,214,981
Messages
6,122,566
Members
449,089
Latest member
Motoracer88

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top