Sub CustomSort()
' Ben Marston
' October 2006
Dim rngList As Range, rngSort As Range
' Get range which defines sort order
On Error Resume Next
Set rngList = Application.InputBox( _
Prompt:="Select column range to set sort order:" & _
Chr(13) & "(shorter of two column ranges)", _
Title:="Get Sort Order", _
Default:=Selection.Address, _
Type:=8)
If rngList Is Nothing Then
MsgBox "Error! No list range selected! Ending program..."
Err.Clear
GoTo EH:
End If
' Create custom list from sort order range
Application.AddCustomList ListArray:=rngList
' Get range to sort in custom sort order
Set rngSort = Application.InputBox( _
Prompt:="Select column range to sort:", _
Title:="Get Sort Range", _
Type:=8)
If rngSort Is Nothing Then
MsgBox "Error! No sort range selected! Ending program..."
Err.Clear
GoTo EH:
End If
On Error GoTo EH:
' Sort range on custom sort order
rngSort.Sort _
Key1:=rngSort.Cells(1, 1), _
Order1:=xlAscending, _
OrderCustom:=Application.CustomListCount + 1, _
MatchCase:=False, _
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
EH:
Application.ScreenUpdating = True
' Alert user of error
With Err
If Err.Number <> 0 Then
MsgBox "Error!" & Chr(13) & _
"Description: " & .Description & Chr(13) & _
"Number: " & .Number, _
vbCritical + vbOKOnly, "Error Message"
End If
End With
' Reset object variables
Set rngList = Nothing
Set rngSort = Nothing
End Sub