在VBA插入sorting – 不工作

我有一个循环，创build一个有理数的随机列表，我试图创build一个macros，将使用插入sortingalgorithm降序组织数字。

创build一个有理数的随机列表：

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 

sortingalgorithm:(不工作）

 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 

我的插入sorting代码不工作 – 任何人都可以build议一个解决scheme？

感谢您的任何帮助。

Answer 1

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

这需要一个数组，并进行插入sorting。 Sub接受ByRef数组意味着你传递给函数的数组实际上是被sorting的，并且没有'before'和'after'数组。

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

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

您可以通过仅使用,1来更新代码以使用2维数组,1每个原始示例使用,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