Сортировка строки - PullRequest
       1

Сортировка строки

0 голосов
/ 02 июля 2018

Я пытаюсь отсортировать строку 'typestr' в алфавитном порядке:

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

Это все работает нормально, пока я не приду к последней функции замены. Опубликовать сначала Заменить-функция строка

typestr = ada

пока моя строка 'temp' равна

temp = c

Так как j = 3 в этой точке, последняя замена должна заменить только последнюю a в ada, но в этом случае типестр заменяется на temp

typestr = c

Ответы [ 5 ]

0 голосов
/ 02 июля 2018

Вот более простой и намного более быстрый способ использования 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

Использование:

MsgBox SortString("cbazyx")

Выход:

abcxyz

0 голосов
/ 02 июля 2018

Минимальное изменение, о котором я знаю, это использование Mid() в левой части назначения (что работает!):

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

При фиксированном свопе test_function("aoiszb") возвращает abiosz.

Единственные существенные изменения, которые я сделал, касались двух строк, помеченных <====. Кроме этого, я добавил код, необходимый для создания MCVE . Я также добавил Option Explicit, поскольку он помогает обнаруживать ошибки и (по моему личному мнению) всегда должен использоваться.

0 голосов
/ 02 июля 2018

Следующий код примет strInput (любую строку) и вернет strOuput в качестве этой строки, отсортированной в алфавитном порядке по возрастанию.

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
0 голосов
/ 02 июля 2018

Решил сам:

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
0 голосов
/ 02 июля 2018

Попробуйте это:

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
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...