Custom VBA Function to sort an array of values.

[Bob 187]

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

 

[Mike H]

Bob,

Unless there is a particular reason for it you don't need a macro it can be
done with a custom list. Try this

Tools|Options|Custom Lists and type

UK*
FRE*
GER

In the right hand pane and click ADD

Then select your list and
Data|Sort|Options
Select your custom list click OK and sort ascending or descending

Mike

 

[Bob 187]

Hi Mike,

Thanks for that, but it does need to be a function as it the list will
become a lot more complex in the future. I just need a start point on how to
develop the function so I can enhance it through time. Any ideas?

Thanks,

Bob

 

[GerryGerry]

is there any logic to the order? I could see the logic if the UKPOW items
were at the bottom of the list. Perhaps the desired function would require 2
lists, one list being the data to be sorted and the other defining the order
in which to sort it.

 

[Charlie]

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