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

Richard Newcombe在 VB.NET 中有一个很好的插入排序实现，可以很容易地在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