Alphabetizing a keywords list

[wardw]

I edit science journal articles that have keyword lists like "linear oscillation; power grid; numerics; power control". I need to alphabetize the terms, but dragging the terms around or building a table of them is a bit cumbersome (time is money :-). Does anyone know of a VBA script that can alphabetize a string like this? I'm thinking there'd need to be a dialog asking what the separators are, because sometimes just commas are used instead of semicolons.

[rstuck]

I have done one off sorts manually by inserting your list into Excel. then do a Text to Column and select your delimiter. This will give you a column for every value. Then I copy the row and do a paste special with a Transpose. This should convert the columns to 1 column but many rows. Then I use Excel to Sort. This is very manual but after doing it a couple of times not too hard. If you have to do this a lot then I would record a macro doing this and then you have your vba script.
Hope it helps

[wardw]

Thanks for this, rstuck. I forgot that all I have to do is record a macro of my procedure, and then tweak the VBA script to fine-tune. (I hope the script is well commented ;-)


I have done one off sorts manually by inserting your list into Excel. then do a Text to Column and select your delimiter. This will give you a column for every value. Then I copy the row and do a paste special with a Transpose. This should convert the columns to 1 column but many rows. Then I use Excel to Sort. This is very manual but after doing it a couple of times not too hard. If you have to do this a lot then I would record a macro doing this and then you have your vba script.
Hope it helps

[gmayor]

You can do this directly in Word without recourse to Excel, by copying the list to an array and sorting the array using a couple of standard functions e.g.


Option Explicit

Sub SortList()
Dim Coll As New Collection
Dim vItems As Variant
Dim oRng As Range
Dim i As Long
Dim sSep As String
Dim sUnsorted As String
Dim sSorted As String
Dim Arr() As Variant

If Len(Selection.Range) = 0 Then
MsgBox "Select the list to be sorted first!"
GoTo lbl_Exit
End If

sSep = InputBox("Enter the separator character", "Sort string", ";")
If InStr(1, Selection.Range, sSep) = 0 Then
MsgBox "The selected separator character is not in the selection?"
GoTo lbl_Exit
End If

Set oRng = Selection.Range
sUnsorted = oRng.Text
sUnsorted = Replace(sUnsorted, Chr(11), "")
sUnsorted = Replace(sUnsorted, Chr(13), "")
vItems = Split(sUnsorted, sSep)

For i = LBound(vItems) To UBound(vItems)
Coll.Add Trim(vItems(i))
Next i

Arr = toArray(Coll) 'convert collection to an array
QuickSort Arr

For i = LBound(Arr) To UBound(Arr)
sSorted = sSorted & Arr(i)
If i < UBound(Arr) Then
sSorted = sSorted & sSep & Chr(32)
End If
Next i
oRng.Text = sSorted

lbl_Exit:
Set Coll = Nothing
Set oRng = Nothing
Exit Sub
End Sub



Private Function toArray(ByVal Coll As Collection) As Variant
Dim Arr() As Variant
Dim i As Long

ReDim Arr(1 To Coll.Count) As Variant
For i = 1 To Coll.Count
Arr(i) = Coll(i)
Next
toArray = Arr

lbl_Exit:
Exit Function
End Function


Private Sub QuickSort(vArray As Variant, _
Optional lng_Low As Long, _
Optional lng_High As Long)

Dim vPivot As Variant
Dim vTmp_Swap As Variant
Dim tmp_Low As Long
Dim tmp_High As Long

If lng_High = 0 Then
lng_Low = LBound(vArray)
lng_High = UBound(vArray)
End If

tmp_Low = lng_Low
tmp_High = lng_High
vPivot = vArray((lng_Low + lng_High) \ 2)

While (tmp_Low <= tmp_High)
While (vArray(tmp_Low) < vPivot And tmp_Low < lng_High)
tmp_Low = tmp_Low + 1
Wend

While (vPivot < vArray(tmp_High) And tmp_High > lng_Low)
tmp_High = tmp_High - 1
Wend

If (tmp_Low <= tmp_High) Then
vTmp_Swap = vArray(tmp_Low)
vArray(tmp_Low) = vArray(tmp_High)
vArray(tmp_High) = vTmp_Swap
tmp_Low = tmp_Low + 1
tmp_High = tmp_High - 1
End If
Wend

If (lng_Low < tmp_High) Then QuickSort vArray, lng_Low, tmp_High
If (tmp_Low < lng_High) Then QuickSort vArray, tmp_Low, lng_High

lbl_Exit:
Exit Sub
End Sub

[SamT]

My attempt at understanding this array sorting technique. It is only Graham's code with different variable names. It works, but I don't guarantee the comments are correct.


Private Sub QuickSort(ByRef vArray As Variant, _
Optional LB As Long, _
Optional UB As Long)
'LB and UB change with each iteration.

Dim Pivot_Item As Variant
Dim vTmp_Swap As Variant
Dim Index_Bigger_Item As Long
Dim Index_Smaller_Item As Long

'Upper and lower boundries for the iterated Sort, not of the actual array
If UB = 0 Then
LB = LBound(vArray)
UB = UBound(vArray)
End If

Index_Bigger_Item = LB
Index_Smaller_Item = UB
Pivot_Item = vArray((LB + UB) \ 2)

While Index_Bigger_Item <= Index_Smaller_Item

'After first iteration, alternate with Find Last Item <=Pivot Item
'Find First Item >= Pivot_Item
While vArray(Index_Bigger_Item) < Pivot_Item And Index_Bigger_Item < UB
Index_Bigger_Item = Index_Bigger_Item + 1
Wend

'find Last Item <= Pivot_Item (alternates with above after first iteration
While vArray(Index_Smaller_Item) > Pivot_Item And Index_Smaller_Item > LB
Index_Smaller_Item = Index_Smaller_Item - 1
Wend

'If Bigger_Item Item before Smaller_Item Item then swap locations
If Index_Bigger_Item <= Index_Smaller_Item Then
vTmp_Swap = vArray(Index_Bigger_Item)
vArray(Index_Bigger_Item) = vArray(Index_Smaller_Item)
vArray(Index_Smaller_Item) = vTmp_Swap

Index_Bigger_Item = Index_Bigger_Item + 1
Index_Smaller_Item = Index_Smaller_Item - 1
End If
Wend

'Find next previous Item smaller than Pivot tem
If Index_Smaller_Item > LB Then QuickSort vArray, LB, Index_Smaller_Item
'find next subsequent Item Larger than Pivot Item
If Index_Bigger_Item < UB Then QuickSort vArray, Index_Bigger_Item, UB

End Sub

[wardw]

Thank you so much, gmayor; your solution works perfectly, lightening fast, and indistinguishable from magic!


You can do this directly in Word without recourse to Excel, by copying the list to an array and sorting the array using a couple of standard functions e.g.


Option Explicit

Sub SortList()
Dim Coll As New Collection
Dim vItems As Variant
Dim oRng As Range
Dim i As Long
Dim sSep As String
Dim sUnsorted As String
Dim sSorted As String
Dim Arr() As Variant

If Len(Selection.Range) = 0 Then
MsgBox "Select the list to be sorted first!"
GoTo lbl_Exit
End If

sSep = InputBox("Enter the separator character", "Sort string", ";")
If InStr(1, Selection.Range, sSep) = 0 Then
MsgBox "The selected separator character is not in the selection?"
GoTo lbl_Exit
End If

Set oRng = Selection.Range
sUnsorted = oRng.Text
sUnsorted = Replace(sUnsorted, Chr(11), "")
sUnsorted = Replace(sUnsorted, Chr(13), "")
vItems = Split(sUnsorted, sSep)

For i = LBound(vItems) To UBound(vItems)
Coll.Add Trim(vItems(i))
Next i

Arr = toArray(Coll) 'convert collection to an array
QuickSort Arr

For i = LBound(Arr) To UBound(Arr)
sSorted = sSorted & Arr(i)
If i < UBound(Arr) Then
sSorted = sSorted & sSep & Chr(32)
End If
Next i
oRng.Text = sSorted

lbl_Exit:
Set Coll = Nothing
Set oRng = Nothing
Exit Sub
End Sub



Private Function toArray(ByVal Coll As Collection) As Variant
Dim Arr() As Variant
Dim i As Long

ReDim Arr(1 To Coll.Count) As Variant
For i = 1 To Coll.Count
Arr(i) = Coll(i)
Next
toArray = Arr

lbl_Exit:
Exit Function
End Function


Private Sub QuickSort(vArray As Variant, _
Optional lng_Low As Long, _
Optional lng_High As Long)

Dim vPivot As Variant
Dim vTmp_Swap As Variant
Dim tmp_Low As Long
Dim tmp_High As Long

If lng_High = 0 Then
lng_Low = LBound(vArray)
lng_High = UBound(vArray)
End If

tmp_Low = lng_Low
tmp_High = lng_High
vPivot = vArray((lng_Low + lng_High) \ 2)

While (tmp_Low <= tmp_High)
While (vArray(tmp_Low) < vPivot And tmp_Low < lng_High)
tmp_Low = tmp_Low + 1
Wend

While (vPivot < vArray(tmp_High) And tmp_High > lng_Low)
tmp_High = tmp_High - 1
Wend

If (tmp_Low <= tmp_High) Then
vTmp_Swap = vArray(tmp_Low)
vArray(tmp_Low) = vArray(tmp_High)
vArray(tmp_High) = vTmp_Swap
tmp_Low = tmp_Low + 1
tmp_High = tmp_High - 1
End If
Wend

If (lng_Low < tmp_High) Then QuickSort vArray, lng_Low, tmp_High
If (tmp_Low < lng_High) Then QuickSort vArray, tmp_Low, lng_High

lbl_Exit:
Exit Sub
End Sub