VBA Code to random sort rows based on value in specific column

[joshuabrent17]

I'm trying to write VBA code that will randomly sort rows of data based on the corresponding value in another column.

My data is in B8:F501 and my helper column that I'm sorting by is column AA beginning in row 8. I'd like it to determine the lastrow based on Column B.

Currently it will sort and throw the rows to the top beginning in row 1 and overwrites all of my headings.

Here is the code I have currently: (the first part works fine - dialog box works properly and a backup copy is saved.) Its the sort part that isn't working properly.

Sub OpenDraw()
Dim varResponse As Variant

varResponse = MsgBox("Are you sure that you wish to randomize the draw? This CAN NOT be undone, but a backup of your file will be created. Select 'Yes' or 'No'", vbYesNo, "Randomize Draw?")
If varResponse <> vbYes Then Exit Sub

Dim wbPath As String
ThisWorkbook.Save
wbPath = ThisWorkbook.Path
wbName = ActiveSheet.Range("R1").Value
ThisWorkbook.SaveCopyAs wbPath & "" & wbName & " - BACKUP " & Format(Now, "yyyymmdd_hhmm") & ".xlsm"
Cells.AutoFilter
If ActiveSheet.AutoFilterMode = False Then
ActiveSheet.Range("B7:F501").AutoFilter
End If
RowCount = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
ActiveWorkbook.ActiveSheet.AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.ActiveSheet.AutoFilter.Sort.SortFields.Add Key:=Range("AA8:AA" & RowCount), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.ActiveSheet.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub

 

[Fluff]

How about

Sub OpenDraw()
Dim varResponse As Variant
Dim rowCount As Long

varResponse = MsgBox("Are you sure that you wish to randomize the draw? This CAN NOT be undone, but a backup of your file will be created. Select 'Yes' or 'No'", vbYesNo, "Randomize Draw?")
If varResponse <> vbYes Then Exit Sub

Dim wbPath As String
ThisWorkbook.Save
wbPath = ThisWorkbook.Path
wbName = ActiveSheet.Range("R1").Value
ThisWorkbook.SaveCopyAs wbPath & "" & wbName & " - BACKUP " & format(Now, "yyyymmdd_hhmm") & ".xlsm"
If ActiveSheet.AutoFilterMode = False Then
   ActiveSheet.Range("B7:AA7").AutoFilter
End If
rowCount = ActiveSheet.Range("B" & Rows.Count).End(xlUp).row
ActiveWorkbook.ActiveSheet.AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.ActiveSheet.AutoFilter.Sort.SortFields.Add key:=Range("AA8:AA" & rowCount), SortOn:=xlSortOnValues, order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.ActiveSheet.AutoFilter.Sort
   .Header = xlYes
   .MatchCase = False
   .Orientation = xlTopToBottom
   .SortMethod = xlPinYin
   .Apply
End With
End Sub

 

[shg]

Another way:

Sub OpenDraw()
  If MsgBox(Prompt:="Are you sure?", Buttons:=vbYesNo, Title:="Randomize Draw?") <> vbYes Then Exit Sub

  With ThisWorkbook
    .SaveCopyAs .Path & "\" & Range("R1").Value & " - BACKUP " & Format(Now, "yyyymmdd_hhmm") & ".xlsm"
  End With
  
  Range("B7", Cells(Rows.Count, "AA")).Sort Key1:=Range("AA7"), Header:=xlYes
End Sub