I use a macro to sort a table by the data in one column:
ActiveWorkbook.Worksheets("sheet").Sort.SortFields.Add Key:=Range(sortRange), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
Is there a way to make this code sort in this order: first 0-9, then A-Z, and then special characters (there are at least • and + which I like to be last in the sort order) ?
Alright, this sounded like a fun task, so I tried Vityata's approach with different lists in another worksheet.
Sub crazySort()
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim lastRow As Long
Dim yourcolumnindex, letters, numbers, others As Long
Dim i As Long
Set ws = Worksheets("sheet")
'This is the sheet for our temp lists, rename accordingly
Set ws2 = Worksheets("tempsheet")
columnsCount = x
i = 1
letters = 1
others = 1
numbers = 1
With ws
For j = 1 to columnsCount
'loop through all the cells in your column
'change yourcolumnindex accordingly
Do While .Cells(i, j) <> ""
'check for the ASCII-code of the first character in every list
Select Case Asc(Left(.Cells(i, j), 1))
Case 65 To 90, 97 To 122
'if it's a letter, put it in column 1
ws2.Cells(letters, 1) = .Cells(i, j)
letters = letters + 1
Case 48 To 57
'if it's a cipher, put it in column 2
ws2.Cells(numbers, 2) = .Cells(i, j)
numbers = numbers + 1
Case Else
'is it something else, put it in column 3
ws2.Cells(others, 3) = .Cells(i, j)
others = others + 1
End Select
i = i + 1
Loop
Next
End With
End Sub
This part just contains splitting the list, but from here on out it's just sorting and the copy/pasting back.
Have fun with this.
@Tom, thanks for mentioning me :) Actually, I was thinking of something more like this:
Public Sub SortMe(rng_selection As Range)
Dim rng_cell As Range
Dim lst_numbers As New Collection
Dim lst_letters As New Collection
Dim lst_others As New Collection
Dim rng_new As Range
For Each rng_cell In rng_selection
Select Case Asc(Left(rng_cell, 1))
Case 65 To 90, 97 To 122
lst_letters.Add rng_cell.Text
Case 48 To 58
lst_numbers.Add rng_cell.Text
Case Else
lst_others.Add rng_cell.Text
End Select
Next rng_cell
Call SortCollection(lst_numbers)
Call SortCollection(lst_letters)
Call SortCollection(lst_others)
For Each rng_cell In rng_selection
If lst_numbers.Count Then
rng_cell = lst_numbers.Item(1)
lst_numbers.Remove (1)
ElseIf lst_letters.Count Then
rng_cell = lst_letters.Item(1)
lst_letters.Remove (1)
ElseIf lst_others.Count Then
rng_cell = lst_others(1)
lst_others.Remove (1)
End If
Next rng_cell
Set rng_new = rng_selection.Offset(0, 1)
End Sub
Sub SortCollection(ByRef oCollection As Collection, Optional bSortAscending As Boolean = True)
'taken from http://visualbasic.happycodings.com/applications-vba/code27.html
Dim lSort1 As Long, lSort2 As Long
Dim vTempItem1 As Variant, vTempItem2 As Variant, bSwap As Boolean
On Error GoTo ErrFailed
For lSort1 = 1 To oCollection.Count - 1
For lSort2 = lSort1 + 1 To oCollection.Count
If bSortAscending Then
If oCollection(lSort1) > oCollection(lSort2) Then
bSwap = True
Else
bSwap = False
End If
Else
If oCollection(lSort1) < oCollection(lSort2) Then
bSwap = True
Else
bSwap = False
End If
End If
If bSwap Then
'Store the items
If VarType(oCollection(lSort1)) = vbObject Then
Set vTempItem1 = oCollection(lSort1)
Else
vTempItem1 = oCollection(lSort1)
End If
If VarType(oCollection(lSort2)) = vbObject Then
Set vTempItem2 = oCollection(lSort2)
Else
vTempItem2 = oCollection(lSort2)
End If
'Swap the items over
oCollection.Add vTempItem1, , lSort2
oCollection.Add vTempItem2, , lSort1
'Delete the original items
oCollection.Remove lSort1 + 1
oCollection.Remove lSort2 + 1
End If
Next
Next
Exit Sub
ErrFailed:
Debug.Print "Error with CollectionSort: " & Err.Description
CollectionSort = Err.Number
On Error GoTo 0
End Sub
It just looks big, the sorting sub is quite big, but I copied and pasted it. It worked for me. If you want to call it, write in the immediate window call SortMe(selection) and do not forget to select the range. :) Have a nice evening :D
