Collapse the list, swap the number to follow the word,
(e.g. "1 FREPOW" --> "FREPOW 1")
sort the list, and swap the number back. The following code requires
1-based string arrays (Option Base 1). Modify as you please to suit. This
will work as long as there is one and only one space in each item of the
list. (Although UKPOW will be at the end not beginning of the list.) If you
can't live with that you'll have to rework the logic.
Option Explicit
Option Base 1
Sub test()
'
Dim List() As String
'
ReDim List(9) ' Hardcode data here for the example
List(1) = "1 UKPOW"
List(2) = "1 GERPOW"
List(3) = "4 FREPOW"
List(4) = "2 FREPOW"
List(5) = "1 FREPOW"
List(6) = "3 GERPOW"
List(7) = "2 UKPOW"
List(8) = "3 FREPOW"
List(9) = "2 GERPOW"
'
List = SwapWords(SortList(SwapWords(CollapseList(List))))
'
End Sub
Public Function CollapseList(List() As String) As String()
'
' removes all blank elements from a string array
'
Dim buf() As String
Dim nItem As Long
Dim nOut As Long
Dim i As Long
'
' get the number of input items
'
nItem = UBound(List)
ReDim buf(nItem)
'
' keep only non-blank items
'
For i = 1 To nItem
If Trim(List(i)) <> "" Then
nOut = nOut + 1
buf(nOut) = List(i)
End If
Next i
'
' return the list
'
ReDim Preserve buf(nOut)
CollapseList = buf
'
End Function
Public Function SwapWords(List() As String) As String()
'
Dim NewList() As String
Dim Swap() As String
Dim tmp As String
Dim i As Long
'
NewList = List
'
' swap on blank space
'
For i = 1 To UBound(NewList)
Swap = Split(NewList(i), " ")
tmp = Swap(0)
Swap(0) = Swap(1)
Swap(1) = tmp
NewList(i) = Join(Swap, " ")
Next i
'
SwapWords = NewList
'
End Function
Public Function SortList(List() As String) As String()
'
' fast "Heap" sort alogrithm from Knuth - The Art of Computer Programming
'
Dim i As Long
Dim j As Long
Dim nItem As Long
Dim ist As Long
Dim lst As Long
Dim tmp As String
Dim buf() As String
'
' need at least two entries in the array to do a sort
'
nItem = UBound(List)
If nItem = 1 Then SortList = List
If nItem < 2 Then Exit Function
'
' set sort pointers to the midpoint and endpoint of the array (NOTE - use
the
' integer division operator!)
'
ist = nItem \ 2 + 1
lst = nItem
buf = List
'
' do an ascending sort
'
110:
If ist > 1 Then
ist = ist - 1
tmp = buf(ist)
Else
tmp = buf(lst)
buf(lst) = buf(1)
lst = lst - 1
If lst = 1 Then
buf(lst) = tmp
SortList = buf
Exit Function
End If
End If
'
j = ist
'
120:
i = j
j = j * 2
'
If j = lst Then
If tmp >= buf(j) Then
buf(i) = tmp
GoTo 110
End If
buf(i) = buf(j)
GoTo 120
End If
'
If j > lst Then
buf(i) = tmp
GoTo 110
End If
'
If buf(j) < buf(j + 1) Then j = j + 1
If tmp >= buf(j) Then
buf(i) = tmp
GoTo 110
End If
'
buf(i) = buf(j)
GoTo 120
'
End Function
"Bob 187" wrote:
> Hi All,
>
> I want to write a custom function that gives me an array of sorted values
> based on a list of strings.
>
> 1 UKPOW
> 1 GERPOW
> 4 FREPOW
> 2 FREPOW
> 1 FREPOW
> 3 GERPOW
> 2 UKPOW
> 3 FREPOW
> 2 GERPOW
>
> I want the function to sort into this order...
>
> 1 UKPOW
> 2 UKPOW
> 1 FREPOW
> 2 FREPOW
> 3 FREPOW
> 4 FREPOW
> 1 GERPOW
> 2 GERPOW
> 3 GERPOW
>
> Also, there may be blank cells within the array, and I want to omit these
> from the sort. Can anyone help please?
>
> Thanks in advance!
>
> Bob
>
|
Similar Threads
