VBA中的插入排序 - 不起作用

Question

我有一个循环创建有理数的随机列表，我正在尝试创建一个宏，该宏将使用插入排序算法降序组织数字。

创建一个随机有理数列表：

Sub SetUpList12()
    Dim UnsortedList(1 To 100, 1 To 1) As Double
    Dim L As Long
    For L = 1 To 100
        UnsortedList(L, 1) = Rnd(-L)
    Next L
    Range("A1:A10").Value = UnsortedList

End Sub

排序算法：（不工作）

Sub InsertSortTest2()

    Dim Num  As Integer
    Dim C  As Integer
    Dim D  As Integer
    Dim Temp  As Integer
    Dim p As Integer

    p = Cells.CurrentRegion.Rows.Count

    Cells(2, 5) = p 'Just to check'

    ReDim Arr(p) As Integer
    Dim i As Long
    Dim R As Long

    For R = 1 To p
        i = Cells(R, 1)
        Num = p
        For C = 0 To Num - 1
            Arr(C) = i
        Next C
        For C = 1 To Num - 1
            D = C
            While D > 0 And (Arr(D) < Arr(D - 1))
                Temp = Arr(D)
                Arr(D) = Arr(D - 1)
                Arr(D - 1) = Temp
                D = D - 1
            Wend
        Next C
        For C = 0 To Num - 1
            Range("A" & C + 1).Value = Arr(C)

        Next C
    Next R
End Sub

我的插入排序代码不起作用 - 谁能提出解决方案？

感谢您的帮助。

Answer 1

在 VB.NET 中有一个通过Richard Newcombe 插入排序的非常好的实现，可以很容易地在 16 行 Excel VBA 中重新编码：

Sub InsertionSort(ByRef varData As Variant)

    Dim lngCounter1 As Long
    Dim lngCounter2 As Long
    Dim varTemp As Variant

    For lngCounter1 = 1 To UBound(varData)
        varTemp = varData(lngCounter1)
        For lngCounter2 = lngCounter1 To 1 Step -1
            If varData(lngCounter2 - 1) > varTemp Then
                varData(lngCounter2) = varData(lngCounter2 - 1)
            Else
                Exit For
            End If
        Next lngCounter2
        varData(lngCounter2) = varTemp
    Next lngCounter1

End Sub

它接受一个数组并进行插入排序。 Sub 采用数组 ByRef 表示您传递给函数的数组实际上已排序，并且没有“之前”和“之后”数组。

以下测试代码显示它适用于Double 和String。在这些示例中，数组 varData 是一个一维数组，因此要让它在列中呈现，您需要使用 Transpose 函数：

ws.Range("B1").Resize(UBound(varData), 1).Value = WorksheetFunction.Transpose(varData)

您可以根据原始示例使用,1 更新代码以使用二维数组。

Option Explicit

Sub DoTests()

    Dim lngItemsToSort As Long
    Dim varData As Variant
    Dim lngCounter As Long
    Dim ws As Worksheet

    ''' double
    ' create 0-base array for test data
    lngItemsToSort = 9 ' 10-element array
    ReDim varData(0 To lngItemsToSort)

    ' get reference to a sheet and clear
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    ws.Cells.ClearContents

    ' create test data for Double
    VBA.Randomize
    For lngCounter = LBound(varData) To UBound(varData)
        varData(lngCounter) = VBA.Rnd
    Next lngCounter

    ' show test data
    ws.Range("A1").Resize(UBound(varData), 1).Value = WorksheetFunction.Transpose(varData)

    ' sort test data
    InsertionSort varData

    ' output sorted test data
    ws.Range("B1").Resize(UBound(varData), 1).Value = WorksheetFunction.Transpose(varData)

    MsgBox "Sorted Double values"

    ''' string
    ' create 0-base array for test data
    lngItemsToSort = 9 ' 10-element array
    ReDim varData(0 To lngItemsToSort)

    ' get reference to a sheet and clear
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    ws.Cells.ClearContents

    ' create test data for Double
    VBA.Randomize
    For lngCounter = LBound(varData) To UBound(varData)
        varData(lngCounter) = Chr(WorksheetFunction.RandBetween(65, 122))
    Next lngCounter

    ' show test data
    ws.Range("A1").Resize(UBound(varData), 1).Value = WorksheetFunction.Transpose(varData)

    ' sort test data
    InsertionSort varData

    ' output sorted test data
    ws.Range("B1").Resize(UBound(varData), 1).Value = WorksheetFunction.Transpose(varData)

    MsgBox "Sorted String values"

End Sub

Sub InsertionSort(ByRef varData As Variant)

    Dim lngCounter1 As Long
    Dim lngCounter2 As Long
    Dim varTemp As Variant

    For lngCounter1 = 1 To UBound(varData)
        varTemp = varData(lngCounter1)
        For lngCounter2 = lngCounter1 To 1 Step -1
            If varData(lngCounter2 - 1) > varTemp Then
                varData(lngCounter2) = varData(lngCounter2 - 1)
            Else
                Exit For
            End If
        Next lngCounter2
        varData(lngCounter2) = varTemp
    Next lngCounter1

End Sub

编辑

以下代码将适用于 OPs 2d 数组：

Option Explicit

Sub SetUpList12()
    Dim UnsortedList(0 To 99, 1 To 1) As Double
    Dim L As Long
    For L = 0 To 99
        UnsortedList(L, 1) = Rnd(-L)
    Next L
    Range("A1:A100").Value = UnsortedList

    'sort the list
    InsertionSort UnsortedList

    Range("B1:B100").Value = UnsortedList

End Sub

Sub InsertionSort2DArrayForRange(ByRef varData As Variant)

    Dim lngCounter1 As Long
    Dim lngCounter2 As Long
    Dim varTemp As Variant

    For lngCounter1 = 1 To UBound(varData, 1)
        varTemp = varData(lngCounter1, 1)
        For lngCounter2 = lngCounter1 To 1 Step -1
            If varData(lngCounter2 - 1, 1) > varTemp Then
                varData(lngCounter2, 1) = varData(lngCounter2 - 1, 1)
            Else
                Exit For
            End If
        Next lngCounter2
        varData(lngCounter2, 1) = varTemp
    Next lngCounter1

End Sub