VBA sort string array function

[cgmojoco]

I have a string that I need to sort.
Below code works beautifully but doesn't sort numbers, any advice to get this to sort numbers as well?

Function Alphabetize(ByVal sText As String) As String
   Dim sWords() As String, sTemp As String
   Dim i As Long, j As Long, n As Long
   
   '-- clean up text
   For i = 1 To Len(sText)
      Select Case Mid$(sText, i, 1)
         Case " ", "a" To "z", "A" To "Z"
         Case Else: Mid$(sText, i, 1) = " "
      End Select
   Next
   '-- remove leading and trailing spaces
   sText = Trim(sText)
   '-- remove multi spaces
   Do While InStr(sText, "  ")
      sText = Replace(sText, "  ", " ")
   Loop
   '-- split text by space
   sWords = Split(sText)
   n = UBound(sWords)
   If n = 0 Then '-- only one word
      Alphabetize = sText
   Else
      '-- sort array
      For i = 0 To n - 1
         For j = i + 1 To n
            If sWords(i) > sWords(j) Then
               sTemp = sWords(i)
               sWords(i) = sWords(j)
               sWords(j) = sTemp
            End If
         Next
      Next
      Alphabetize = Join(sWords, ",")
   End If
End Function

 

[Scott Huish]

You didn't say but this appears to alphabetize words separated by space, and then concatenate them with commas.

How would you enter the numbers? Can you provide some samples and expected results?

 

[cgmojoco]

Good question

Unfortunatley, I have to keep this rather generic because I am using this in conjunction with another function, so the numbers are input into the string array in any number of formats.

Here is the whole thing.

Basically the original function is a vlookup that concatenates multiple unique values it finds into one cell deliminated by any delimiter chosen by the user:

Option Explicit
'Original function written by "parmel" on MR.Excel.com and modified below
'This is a SLOW function that returns multiple UNIQUE lookup values into one cell
Function muvlookup(strIndex As String, r As Range, Optional icol As Integer, Optional strDEL As String) As String
'strIndex is the matching criteria
'r is the range to look in
'Optional i is the column# in the range to return values, default is 1 (return column value to right of criteria match)
'Optional strDEL is an optional deliminator to separate values, default is ","
'use the dictionary object to find the duplicate entries
Dim c As Range, l As String, sResult As Variant
Dim dict As Variant
Application.Volatile
sResult = ""
Set dict = CreateObject("Scripting.Dictionary")
If icol = 0 Then
icol = -1
End If
If strDEL = "" Then
strDEL = ","
End If
For Each c In r
    'do only for the index of interest
    If strIndex <> "" Then
        If c.Offset(0, -1 * icol) = strIndex Then
          'use the value (apple, elephant, etc.) as the key and the index as the value
          'if it's not a repeat of apple, elephant, etc.) add the entry to the dictionary
          'and concatenate the value to the final string (sResult)
          If Not dict.Exists(c.Value) Then
                dict.Add c.Value, c.Offset(0, 1).Value
                If sResult <> "" Then
                    sResult = sResult & strDEL & c.Value
 
                    Else
                   sResult = c.Value
                End If
          End If
        End If
    End If
Next c
muvlookup = Alphabetize(sResult)
End Function
'-----------------------------------------------------------------
Function Alphabetize(ByVal sText As String) As String
   Dim sWords() As String, sTemp As String
   Dim i As Long, j As Long, n As Long
 
   '-- clean up text
   For i = 1 To Len(sText)
      Select Case Mid$(sText, i, 1)
         Case " ", "a" To "z", "A" To "Z"
         Case Else: Mid$(sText, i, 1) = " "
      End Select
   Next
   '-- remove leading and trailing spaces
   sText = Trim(sText)
   '-- remove multi spaces
   Do While InStr(sText, "  ")
      sText = Replace(sText, "  ", " ")
   Loop
   '-- split text by space
   sWords = Split(sText)
   n = UBound(sWords)
   If n = 0 Then '-- only one word
      Alphabetize = sText
   Else
      '-- sort array
      For i = 0 To n - 1
         For j = i + 1 To n
            If sWords(i) > sWords(j) Then
               sTemp = sWords(i)
               sWords(i) = sWords(j)
               sWords(j) = sTemp
            End If
         Next
      Next
      Alphabetize = Join(sWords, ",")
   End If
End Function

Highlighted in red is where I call the other function that I need to also sort #'s....(also #'s should appear before text of course)
Changing the delimiter of the original function (it is an optional part of the function to put in a custom delimiter) doesn't change the outcome of the alphabetize function as far as I can tell, I could optionally pass the custom delimiter string to the alphabetize function just to make sure things work in all scenarios but haven't gotten that far...

 

[jindon]

What are you really trying to do with those functions ?

You are passing String variable (sResul) to the sort function, but
Why not passing Array (dict.keys) to the sort routine, instead of String variable?

 

[cgmojoco]

Right, perhaps you can move me along in the proper direction and explain... I did try sorting the dictionary but that seemed more complex and I couldn't figure it out...Perhaps you can show me how to send the dictionary to a decent sort routine (like C.Pearsons? http://www.cpearson.com/excel/QSort.htm) Maybe I just need to convert the dictionary to an array? I don't know I am lost!

It is my understanding that the dictionary is being converted to a string with words separated by spaces. The 2nd function ensures this and then sorts the individual words. Numbers aren't coming out of the 2nd function at all it seems...

So this attempt at coding "Sort of" (pardon the pun) works for me

If I am not clear.

What all this is meant to do is allow me to do a vlookup that returns multiple "tokens" into one cell, sorted and separated by a delimiter of choice (defined in the function)

 

[jindon]

Sort routine is not so simple...
Think about those data

123abc
1abc
22222dec
1111aaa

just try to sort them on the worksheet and compare the result with your expectations.

 

[cgmojoco]

Thanks Jindon, what would you recommend?

If I could use a sort routine that get's what excel does when you sort that data you just showed me I would be fine with that.

Am I missing something other than this might make for a REALLY slow function?

 

[cgmojoco]

Perhaps you can also show me how I can get my custom delimiter to a module level variable that I can pass to the 2nd function?

I can't seem to figure that out either---I'm stuck defining the variable in the function declaration itself...

 

[jindon]

try
=VLookUpMulti(A1, C1:D100, 2, ",", False)

Function VLookUpMulti(ByVal strIndex As String, ByVal rng As Range, _
                 Optional ref As Integer = 1, Optional myJoin As String = " ", _
                 Optional myOrd As Boolean = True) As String
Dim a, b(), i As Long, n As Long
a = rng.Value
ReDim b(1 To UBound(a,1), 1 To 2)
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For i = 1 To UBound(a,1)
        If a(i,1) = strIndex Then
            If Not .exists(a(i, ref)) Then
                .add a(i,2), Nothing
                n = n + 1 : b(n,1) = a(i,2)
                b(n,2) = IIf(IsNumeric(a(i,2)),a(i,2), UCase(a(i,2)))
            End If
        End If
    Next
End With
VSortM b, 1, n, 2, False
For i = 1 To n
    VLookUpMulti = VLookUpMulti & IIf(vLookUpMulti = "", "", myJoin) & b(i, 1)
Next
End Function
 
Sub VSortM(ary, LB, UB, ref, myOrd) 
Dim i As Long, ii As Long, iii As Long, M, temp 
i = UB : ii = LB 
M = ary(Int((LB+UB)/2),ref) 
Do While ii <= i 
    If myOrd Then 
        Do While ary(ii,ref) < M : ii = ii + 1 : Loop 
        Do While ary(i,ref) > M : i = i - 1 : Loop 
    Else 
        Do While ary(ii,ref) > M : ii = ii + 1 : Loop 
        Do While ary(i,ref) < M : i = i - 1 : Loop 
    End If 
    If ii <= i Then 
        For iii = LBound(ary,2) To UBound(ary,2) 
            temp = ary(ii,iii) : ary(ii,iii) = ary(i,iii) : ary(i,iii) = temp 
        Next 
        i = i - 1 : ii = ii + 1 
    End If 
Loop 
If LB < i Then VSortM ary, LB, i, ref, myOrd 
If ii < UB Then VSortM ary, ii, UB, ref, myOrd 
End Sub

 

[cgmojoco]

Thanks---and FAST (both your post and the code!)

Jindon,
How to put the order in ascending?

You are amazing, thanks again!