Alphabatize a string using VBA - For excel function

[chopin2256]

Hi!

The program I am using is excel. What I am looking to do is alphabetize a string within a cell. Note, I do not wish to alphabetize a column of words.

Here is an example. Let's say cell A1 contains a string like so:

"The Law Firm of Cohen & Jaffe"

I would like to alphabetize this whole string, within the cell. Any garbage characters I would not worry about, I can always get rid of them using find and replace. The important thing, is to alphabetize the string.

The purpose of this task, is because I need to match data from 2 different databases, but some fields on the other database, although similar, are off just by a little (such as, reverse ordering). That is why I cannot use a normal sort function in excel to match the two datasets. Thus, the reason why I need to alphabetize a string, within a cell.

Thanks for your help!

[QVeen72]

Hi,

I'am not sure what you actually mean by Alphabetize...?
So what would this
"The Law Firm of Cohen & Jaffe"
look like after conversion..?

Regards
Veena

[chopin2256]

Hi! Thanks for replying.

I mean sorting an array. For example, the array output would look like:

"Cohen Firm Jaffe Law of The"

Again, I can manually eliminate the garbage characters using find and replace.

[chopin2256]

I found this code, but it doesn't work in VBA. Maybe you can help me tweak it to perform the desired results?

' Takes any string, alphabetizes it, and returns the alphabetized string
    Private Function Alphabetize(ByVal originalString As String) As String
        Dim alphabetizedString As String = ""
        Dim tempString As String
        Dim Iterator As Integer
        Dim closestToA As Char
        Dim positionToRemove As Integer
        Dim charsToRemove As Integer
        Dim tempIterator As Integer

        tempString = originalString
        charsToRemove = tempString.Length

        ' Two For loops to work through the string; first one is to ensure
        ' removal of one character each pass; second one loops through
        ' all characters in the current temporary string
        For Iterator = 0 To charsToRemove - 1
            ' Set the character closest to a as equal to the first character
            ' of the temporary string
            closestToA = tempString.Chars(0)
            positionToRemove = 0

            For tempIterator = 1 To tempString.Length - 1
                If tempString.Chars(tempIterator) < closestToA Then
                    closestToA = tempString.Chars(tempIterator)
                    positionToRemove = tempIterator
                End If
            Next tempIterator

            ' Remove selected character from tempstring and append it to alphabetizedString
            tempString = tempString.Remove(positionToRemove, 1)
            alphabetizedString &= closestToA.ToString
        Next Iterator

        Return alphabetizedString

    End Function    ' Alphabetize

[chopin2256]

I discovered the solution to this request, and I will post it so others can benefit, if they ever come across the same problem I had:

Function alphasort(r As Range)
      Dim c() As String
      c = Split(r.Value)
      qs c, LBound(c), UBound(c)
      alphasort = Join(c)
      End Function
      Function qs(c() As String, ByVal First As Long, ByVal Last As Long)
          Dim Low As Long, High As Long
          Dim MidValue As String
         
          Low = First
          High = Last
          MidValue = c((First + Last) \ 2)
         
          Do
              Do While c(Low) < MidValue
                  Low = Low + 1
              Loop
              Do While c(High) > MidValue
                  High = High - 1
              Loop
                      If Low <= High Then
      ''                    Swap C(High), C(Low)
                      tempC = c(Low)
                      c(Low) = c(High)
                      c(High) = tempC
                         
                     
                  Low = Low + 1
                  High = High - 1
              End If
          Loop While Low <= High
         
          If First < High Then qs c, First, High
          If Low < Last Then qs c, Low, Last
          qs = c
       
      End Function

Another solution I found, which alphabetizes the whole sentence (not words)

Sub SortCell()
Dim Source As Range, Target As Range
Dim c As Range
Dim i As Long
Dim Temp()

Set Target = Selection.CurrentRegion.Offset(0, 1)
Set Target = Target.Resize(, 1)
Target.Clear
Set Source = Selection.CurrentRegion

For Each c In Source
ReDim Temp(0 To Len(c.Text) - 1)
For i = 0 To UBound(Temp)
Temp(i) = Mid(c.Text, i + 1, 1)
Next i
SingleBubbleSort Temp
c.Offset(0, 1).Value = Join(Temp, "")
Next c
End Sub

Function SingleBubbleSort(TempArray As Variant)
'copied directly from support.microsoft.com
Dim Temp As Variant
Dim i As Integer
Dim NoExchanges As Integer

' Loop until no more "exchanges" are made.
Do
NoExchanges = True

' Loop through each element in the array.
For i = 0 To UBound(TempArray) - 1

' If the element is greater than the element
' following it, exchange the two elements.
If TempArray(i) > TempArray(i + 1) Then
NoExchanges = False
Temp = TempArray(i)
TempArray(i) = TempArray(i + 1)
TempArray(i + 1) = Temp
End If
Next i
Loop While Not (NoExchanges)

End Function

Thanks for all of those who have looked through my thread! My request has been resolved.