如何在VBA中对具有多个小数位的数字字符串进行排序

Question

我目前有一个包含 2000 多行数据的 Excel 电子表格。在其中一列中，我有一个 ID，它是一个包含多个小数点的字符串。我需要根据这个 ID 对我的 Excel 电子表格中的数据进行排序。 ID 的列如下所示：

1.01.1.3.1
1.01.1.5.2
1.01.1.3.13
1.01.1.3.2
1.02.5.1.1.1.1
1.01.1.3.1.1
1.01.1.3.2.1

结果需要如下所示：

1.01.1.3.1
1.01.1.3.1.1
1.01.1.3.2
1.01.1.3.2.1
1.01.1.3.13
1.01.1.5.2
1.02.5.1.1.1.1

我正在使用 VBA 从电子表格中提取数据并存储在一个数组中，但我不确定如何从左到右对字符串进行排序。我知道我必须用“。”分割每个条目。并对第一个索引进行排序，然后对下一个索引进行排序，但我担心这种方法会花费超过 2000 个条目的时间。与具有 9 个索引的条目（例如：1.01.1.1.2.5.1.1.1）相比，我也不确定如何处理具有 5 个索引（例如：1.01.1.1.1）的条目

另一个问题是某些条目包含字母。例如：1.01.1.4.1A

注意，我有这个 BubbleSort 功能：

Public Function BubbleSort(ByVal tempArray As Variant) As Variant
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

            ' Substitution when element is greater than the element following int
            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)

    BubbleSort = tempArray

End Function

如果有人对解决方案有任何见解，我们非常感谢您的帮助。

Answer 1

我从我的排序例程库中获取了以下内容。请忽略我的一些命名约定:)。

经过审核，我注意到我的 CompareNaturalNum() 例程存在问题 “1.01.1.3.1”和“1.01.1.3.1.1”相同。我已经在下面的代码中修复了它，并展示了如何使用它。

QuickSortMultiNaturalNum - 变体数组的快速排序，您可以在其中指定要排序的列。

Public Sub QuickSortMultiNaturalNum(strArray As Variant, intBottom As Long, intTop As Long, intSortIndex As Long, Optional intLowIndex As Long, Optional intHighIndex As Long = -1)
Dim strPivot As String, strTemp As String
Dim intBottomTemp As Long, intTopTemp As Long
Dim i As Long

intBottomTemp = intBottom
intTopTemp = intTop

If intHighIndex < intLowIndex Then
    If (intBottomTemp <= intTopTemp) Then
        intLowIndex = LBound(strArray, 2)
        intHighIndex = UBound(strArray, 2)
    End If
End If

strPivot = strArray((intBottom + intTop) \ 2, intSortIndex)

While (intBottomTemp <= intTopTemp)

' < comparison of the values is a descending sort
While (CompareNaturalNum(strArray(intBottomTemp, intSortIndex), strPivot) < 0 And intBottomTemp < intTop)
    intBottomTemp = intBottomTemp + 1
Wend

While (CompareNaturalNum(strPivot, strArray(intTopTemp, intSortIndex)) < 0 And intTopTemp > intBottom)
    intTopTemp = intTopTemp - 1
Wend

If intBottomTemp < intTopTemp Then
    For i = intLowIndex To intHighIndex
        strTemp = Var2Str(strArray(intBottomTemp, i))
        strArray(intBottomTemp, i) = Var2Str(strArray(intTopTemp, i))
        strArray(intTopTemp, i) = strTemp
    Next
End If

If intBottomTemp <= intTopTemp Then
    intBottomTemp = intBottomTemp + 1
    intTopTemp = intTopTemp - 1
End If

Wend

'the function calls itself until everything is in good order
If (intBottom < intTopTemp) Then QuickSortMultiNaturalNum strArray, intBottom, intTopTemp, intSortIndex, intLowIndex, intHighIndex
If (intBottomTemp < intTop) Then QuickSortMultiNaturalNum strArray, intBottomTemp, intTop, intSortIndex, intLowIndex, intHighIndex
End Sub

CompareNaturalNum - 自定义比较功能

Function CompareNaturalNum(string1 As Variant, string2 As Variant) As Long
'string1 is less than string2 -1
'string1 is equal to string2 0
'string1 is greater than string2 1
Dim n1 As Long, n2 As Long
Dim iPosOrig1 As Long, iPosOrig2 As Long
Dim iPos1 As Long, iPos2 As Long
Dim nOffset1 As Long, nOffset2 As Long

    If Not (IsNull(string1) Or IsNull(string2)) Then
        iPos1 = 1
        iPos2 = 1
        Do While iPos1 <= Len(string1)
            If iPos2 > Len(string2) Then
                CompareNaturalNum = 1
                Exit Function
            End If
            If isDigit(string1, iPos1) Then
                If Not isDigit(string2, iPos2) Then
                    CompareNaturalNum = -1
                    Exit Function
                End If
                iPosOrig1 = iPos1
                iPosOrig2 = iPos2
                Do While isDigit(string1, iPos1)
                    iPos1 = iPos1 + 1
                Loop

                Do While isDigit(string2, iPos2)
                    iPos2 = iPos2 + 1
                Loop

                nOffset1 = (iPos1 - iPosOrig1)
                nOffset2 = (iPos2 - iPosOrig2)

                n1 = Val(Mid(string1, iPosOrig1, nOffset1))
                n2 = Val(Mid(string2, iPosOrig2, nOffset2))

                If (n1 < n2) Then
                    CompareNaturalNum = -1
                    Exit Function
                ElseIf (n1 > n2) Then
                    CompareNaturalNum = 1
                    Exit Function
                End If

                ' front padded zeros (put 01 before 1)
                If (n1 = n2) Then
                    If (nOffset1 > nOffset2) Then
                        CompareNaturalNum = -1
                        Exit Function
                    ElseIf (nOffset1 < nOffset2) Then
                        CompareNaturalNum = 1
                        Exit Function
                    End If
                End If
            ElseIf isDigit(string2, iPos2) Then
                CompareNaturalNum = 1
                Exit Function
            Else
                If (Mid(string1, iPos1, 1) < Mid(string2, iPos2, 1)) Then
                    CompareNaturalNum = -1
                    Exit Function
                ElseIf (Mid(string1, iPos1, 1) > Mid(string2, iPos2, 1)) Then
                    CompareNaturalNum = 1
                    Exit Function
                End If
                iPos1 = iPos1 + 1
                iPos2 = iPos2 + 1
            End If
        Loop
        ' Everything was the same so far, check if Len(string2) > Len(String1)
        ' If so, then string1 < string2
        If Len(string2) > Len(string1) Then
            CompareNaturalNum = -1
            Exit Function
        End If
    Else
        If IsNull(string1) And Not IsNull(string2) Then
            CompareNaturalNum = -1
            Exit Function
        ElseIf IsNull(string1) And IsNull(string2) Then
            CompareNaturalNum = 0
            Exit Function
        ElseIf Not IsNull(string1) And IsNull(string2) Then
            CompareNaturalNum = 1
            Exit Function
        End If
    End If
End Function

isDigit - 让您知道字符串值是否为数字 (0-9) 的简单函数

Function isDigit(ByVal str As String, pos As Long) As Boolean
Dim iCode As Long
    If pos <= Len(str) Then
        iCode = Asc(Mid(str, pos, 1))
        If iCode >= 48 And iCode <= 57 Then isDigit = True
    End If
End Function

Var2Str - 因为它处理变体，值可能是Null，所以将其转换为字符串

Public Function Var2Str(Value As Variant, Optional TrimSpaces As Boolean = True) As String
    If IsNull(Value) Then
        'Var2Str = vbNullString
        Exit Function
    End If
    If TrimSpaces Then
        Var2Str = Trim(Value)
    Else
        Var2Str = CStr(Value)
    End If
End Function

测试 - 这是如何使用它的示例代码。只需更改范围值。对QuickSortMultiNaturalNum 的调用中的最后一个1 是要排序的列（ID 所在的列）。

Sub Test()
Dim Target As Range
Dim vData 'as Variant
Dim Rows As Long
    ' Set Target to the CurrentRegion of cells around "A1"
    Set Target = Range("A1").CurrentRegion
    ' Copy the values to a variant
    vData = Target.Value2
    ' Get the high/upper limit of the array
    Rows = Target.Rows.Count    'UBound(vData, 1)
    ' Sor The variant array, passing the variant, lower limit, upper limit and the index of the column to be sorted.
    QuickSortMultiNaturalNum vData, 1, Rows, 1
    ' Paste the values back onto the sheet.  For testing, you may want to paste it to another sheet/range
    Range("A1").Resize(Target.Rows.Count, Target.Columns.Count).Value = vData
End Sub

Answer 2

如果允许您使用其他列，请执行以下操作：

• 将 ID 列复制到新列
• 检查每个单元格中的最大点数
• 从每个单元格中删除每个非数字 [^0-9] 和非点 [^.]
• 修改每个单元格，包括最大的点数，如下所示：

发件人：

1.01.1.3.13

收件人：

1.01.01.03.13.00

• 例如如果它仅包含 1 个值并添加额外的点，则添加一个零，以用点数等于最大值。

• 在新列中删除点

• 按新列排序
• 删除新列
• 就是这样！

如果您不允许使用额外的列，那么您应该使用一些映射技术。

Answer 3

此代码使用. 分隔符分割范围。
然后在根据拆分进行排序之前，将 0 添加到拆分中的空白单元格，但也包括原始文本。
然后清除拆分的单元格，只留下排序后的原始值。
1.01.1.4.1A 出现在1.01.1.3.13 和1.01.1.5.2 之间。

Sub Test()

    Dim wrkSht As Worksheet
    Dim rng As Range
    Dim rng_Split As Range
    'Dim rng_Blanks As Range - EDIT: Not needed.
    Dim lLastCol As Long
    Dim rCol As Range

    Set wrkSht = ThisWorkbook.Worksheets("Sheet1")

    'Split the value and find the last column it splits to.
    With wrkSht
        'Adjust the range to yours.
        Set rng = .Range("A31:A38")

        rng.TextToColumns _
            Destination:=rng.Offset(, 1), _
            DataType:=xlDelimited, _
            Other:=True, _
            OtherChar:="."

        lLastCol = rng.EntireRow.Cells.Find("*", , , , xlByColumns, xlPrevious).Column
    End With

    'Add a 0 to all blank cells.
    Set rng_Split = rng.Offset(, 1).Resize(rng.Rows.Count, lLastCol - 1)
    rng_Split.SpecialCells(xlCellTypeBlanks).Value = 0

    With wrkSht
        With .Sort
            .SortFields.Clear
            For Each rCol In rng_Split.Columns
                .SortFields.Add Key:=rCol, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            Next rCol
            'Adjust this range to include all columns to be sorted.
            .SetRange rng_Split.Offset(, -1).Resize(, lLastCol)
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .Apply
        End With
    End With

    rng_Split.ClearContents

End Sub

编辑：使用这种方法01和1被认为是一样的。