CODEWITHSUNDEEP
stringvbaexcelsorting
user7690917
user7690917

Reputation:

Sorting a string

I'm trying to sort a string 'typestr' alphabetically:

typestr = "cda"
Dim temp As String
For i = 1 To Len(typeStr) - 1
    For j = i + 1 To Len(typeStr)
        If Mid(typeStr, i, 1) > Mid(typeStr, j, 1) Then
            temp = Mid(typeStr, i, 1)
            typeStr = Replace(typeStr, Mid(typeStr, i, 1), Mid(typeStr, j, 1), i, 1)
            typeStr = Replace(typeStr, Mid(typeStr, j, 1), temp, j, 1)
        End If
    Next j
Next i

This all works fine until I come to the last Replace-function. Post first Replace-function the string is 

typestr = ada

while my 'temp'-string is

temp = c

Since j = 3 at this point, the last replace should replace only the last a in ada, but what happens is that typestr gets replaced with temp

typestr = c

Upvotes: 1

Views: 450

Answers (5)

41686d6564
41686d6564

Reputation: 19661

Here's an easier and much faster way using ArrayList:

Function SortString(inputStr As String) As String
    Dim list As Object
    Set list = CreateObject("System.Collections.ArrayList")

    For i = 1 To Len(inputStr)
        list.Add (Mid$(inputStr, i, 1))
    Next
    list.Sort

    SortString = Join(list.ToArray, "")
End Function

Usage:

MsgBox SortString("cbazyx")

Output:

abcxyz

Upvotes: 2

cxw
cxw

Reputation: 17051

The minimal change I know of is to use Mid() on the left-hand side of an assignment (which works!):

Option Explicit

Public Function test_function(typeStr As String) As String
    Dim i As Long, j As Long
    Dim temp As String

    For i = 1 To Len(typeStr) - 1
        For j = i + 1 To Len(typeStr)
            If Mid(typeStr, i, 1) > Mid(typeStr, j, 1) Then
                temp = Mid(typeStr, i, 1)
                Mid(typeStr, i, 1) = Mid(typeStr, j, 1)    ' <====
                Mid(typeStr, j, 1) = temp                  ' <====
            End If
        Next j
    Next i
    test_function = typeStr
End Function

With the swap fixed, test_function("aoiszb") returns abiosz.

The only substantive changes I made were to the two lines marked <====. Other than that, I added the code necessary to make an MCVE. I also added Option Explicit since it helps catch bugs and (in my personal opinion) should always be used.

Upvotes: 0

user7690917
user7690917

Reputation:

Solved it myself:

Function test_function(typestr As String)

    For i = 1 To Len(typestr) - 1
        For j = i + 1 To Len(typestr)
            If Mid(typestr, i, 1) > Mid(typestr, j, 1) Then
                temp = Mid(typestr, i, 1)
                typestr = Replace(typestr, Mid(typestr, i, 1), Mid(typestr, j, 1), 1, 1)
                typestr = Left(typestr, j - 1) & Replace(typestr, Mid(typestr, j, 1), temp, j, 1)
            End If
        Next j
    Next i

    test_function = typestr

End Function

Upvotes: 0

Bill Hileman
Bill Hileman

Reputation: 2836

The following code will accept strInput (any string) and return strOuput as that string sorted alphabetically ascending.

strOutput = Left(strInput, 1)

For intCnt = 2 To Len(strInput)
    strChar = Mid(strInput, intCnt, 1)
    For intChk = 1 To Len(strOutput)
        If strChar < Mid(strOutput, intChk, 1) Then
            strOutput = Left(strOutput, intChk - 1) + strChar + Mid(strOutput, intChk)
            strChar = ""
            Exit For
        End If
    Next intChk
    strOutput = strOutput + strChar
Next intCnt

Upvotes: 0

Pawel Czyz
Pawel Czyz

Reputation: 1645

Try this:

Sub Alphabetically_SortArray()

my_string = InputBox("Provide a string. It will be sorted alphabetically")

Dim buff() As String
ReDim buff(Len(my_string) - 1)
For i = 1 To Len(my_string)
    buff(i - 1) = Mid$(my_string, i, 1)
Next

Dim myArray As Variant
Dim x As Long, y As Long
Dim TempTxt1 As String
Dim TempTxt2 As String

myArray = buff

'Alphabetize Sheet Names in Array List
  For x = LBound(myArray) To UBound(myArray)
    For y = x To UBound(myArray)
      If UCase(myArray(y)) < UCase(myArray(x)) Then
        TempTxt1 = myArray(x)
        TempTxt2 = myArray(y)
        myArray(x) = TempTxt2
        myArray(y) = TempTxt1
      End If
     Next y
  Next x

  i = 0
  For Each Item In myArray
    result = result & myArray(i)
    i = i + 1
  Next Item

  MsgBox result

End Sub

Upvotes: 0

Related Questions