http://topic.csdn.net/u/20110104/19/c7ad4498-5b3c-46cb-a0e5-2cbb080349ea.html

Option Explicit Dim a() As Single Dim b() As Long '用于存放a()数组的索引 Dim N As Long '数组元素的个数 Dim MaxValueCounts As Long '筛选最大数值的个数 Private Sub Form_Click() Dim i As Long,j As Long,k As Long Dim t1 As Double,t2 As Double Dim Middle As Long,d As Single Dim LeftIndex As Long,RightIndex As Long N = Input<a href="https://www.jb51.cc/tag/Box/" target="_blank" class="keywords">Box</a>("请输入将要录入的数据个数","<a href="https://www.jb51.cc/tag/tishi/" target="_blank" class="keywords">提示</a>") MaxValueCounts = Input<a href="https://www.jb51.cc/tag/Box/" target="_blank" class="keywords">Box</a>("请输入筛选最大数值的个数","<a href="https://www.jb51.cc/tag/tishi/" target="_blank" class="keywords">提示</a>") ReDim a(N) ReDim b(MaxValueCounts + 1) Randomize For i = 1 To N Step 1 a(i) = Rnd Next i t1 = Timer '------------------------------从小到大排序----------------------------- a(0) = -100 '为a(0)预赋一个数组中的最小值 b(0) = 0 b(1) = 1 For i = 2 To N Step 1 'For j = i - 1 To 0 Step -1 LeftIndex = 1 RightIndex = i - 1 If RightIndex > MaxValueCounts Then RightIndex = MaxValueCounts Middle = Int((LeftIndex + RightIndex) / 2) Do Select Case a(b(Middle)) Case Is = a(i) For k = MaxValueCounts - 1 To Middle + 1 Step -1 b(k + 1) = b(k) Next k b(Middle + 1) = i Exit Do Case Is < a(i) If LeftIndex >= RightIndex Then For k = MaxValueCounts - 1 To Middle + 1 Step -1 b(k + 1) = b(k) Next k b(Middle + 1) = i Exit Do End If LeftIndex = Middle + 1 Case Is > a(i) If LeftIndex >= RightIndex Then For k = MaxValueCounts - 1 To Middle Step -1 b(k + 1) = b(k) Next k b(Middle) = i Exit Do End If RightIndex = Middle End Select Middle = Int((LeftIndex + RightIndex) / 2) Loop 'If j = 0 Then a(j) = a(i) - 1 '当a(0)为无穷小时，可以省略该行。 'If a(i) >= a(b(j)) Then ' For k = i - 1 To j + 1 Step -1 ' b(k + 1) = b(k) ' Next k ' b(j + 1) = i ' Exit For 'End If 'Next j Next i '-------------------------------完成排序-------------------------------- t2 = Timer Msg<a href="https://www.jb51.cc/tag/Box/" target="_blank" class="keywords">Box</a> t2 - t1 Me.AutoRedraw = True For i = 1 To MaxValueCounts Step 1 Me.Print a(b(i)) Next i End Sub

引用小吉回复：

对于，MaxValueCounts取值，比较大时，可以考虑用CopyMemory代替内层循环后移数据
如：

For k = MaxValueCounts - 1 To Middle + 1 Step -1 b(k + 1) = b(k) Next k

可换成

CopyMemory b(Middle + 2),b(Middle + 1),(MaxValueCounts - Middle - 1) * 4

注意：这样修改后，MaxValueCounts千万不能小于3，否则可能会崩的!!!在完整排序，即MaxValueCounts=N时，这种变动，能让IDE下的速度一下提高20倍，吓了我一跳！当然，对N代码编译后，这种修改是无效的，速度提高不足3%，而且，估计在MaxValueCounts取值较小时，可能效率还会下降。对P代码编译比较实用。