|
|
楼主 |
发表于 2023-2-11 09:23
|
显示全部楼层
'这个也是高手做的排序程序
Option Explicit
'接收输入：
Dim s, r, n, i
s=inputbox(vbcrlf & vbcrlf & "以空格隔开：","请输入一组数字或字符串：","? + A # 201 * c2 1 $ b 18 / ( A23 _ 15 A1 a1 & \ @ ~ ) - = ^ 4D ? 35 , 67 ! CB 21 % 10")
If s = "" Then wscript.quit
r = Split(s, " ")
n = UBound(r)
'把字符串转换为Double 子类型：
'For i = 0 To n
' r(i) = CDBL(r(i))
'Next
'快速排序方法调用：
quicksort r, 0, n '快速排序
'其它排序方法的调用：
'insertsort r '插入排序
'shellsort r '希尔排序
'bubblesort r '冒泡排序
'selectsort r '选择排序
'heapsort r '堆排序
'输出结果：
inputbox vbcrlf & vbcrlf & "按升序排列是：","结果",join(r," ")
'各种排序子过程自定义：
'快速排序：
Sub quicksort(ReArr, head, tail)
'ReArr是待排序数组，head和tail是该数组的最小下标和最大下标
Dim lef,rig
Dim pivot
If head<tail Then
lef=head
rig=tail
pivot=ReArr(lef)
While (lef<>rig)
While (lef<rig and ReArr(rig)>=pivot)
rig=rig-1
Wend
If lef<rig Then
ReArr(lef)=ReArr(rig)
lef=lef+1
End If
While (lef<rig and ReArr(lef)<=pivot)
lef=lef+1
Wend
If lef<rig Then
ReArr(rig)=ReArr(lef)
rig=rig-1
End If
Wend
ReArr(lef)=pivot
call quicksort(ReArr,head,lef-1)
call quicksort(ReArr,lef+1,tail)
End If
End Sub
'插入排序：
Sub insertsort(r)
Dim i, n, t, j
n = UBound(r)
For i = 1 To n '依次插入r(1),r(2),...,r(n)
t = r(i)
j = i - 1
Do While t < r(j) '查找r(i)的插入位置
r(j + 1) = r(j) '将大于r(i)的数后移
j = j - 1
If j = -1 Then Exit Do
Loop
r(j + 1) = t '插入r(i)
Next
End Sub
'希尔排序：
Sub shellsort(r)
'设置增量序列：
Dim i, d(), n, t, k, h, j
n = UBound(r)
i = 0
ReDim d(n)
d(i) = Fix(n / 2)
Do Until d(i) = 1
t = d(i)
i = i + 1
d(i) = Fix(t / 2)
Loop
'排序：
k = 0
Do
h = d(k) '取本趟增量
For i = h To n 'r(h)到r(n)插入当前有序区
t = r(i) '保存待插入数
j = i - h
Do While t < r(j) '查找正确的插入位置
r(j + h) = r(j) '后移
j = j - h '得到前一数的位置
If j < 0 Then Exit Do
Loop
r(j + h) = t '插入r(i)
Next '本趟排序完成
k = k + 1
Loop While h <> 1
End Sub
'冒泡排序：
Sub bubblesort(r)
Dim i, n, noswap, j, t
n = UBound(r)
For i = 0 To n - 1 '做n趟排序
noswap = True '置未交换标志
For j = n - 1 To i Step -1 '从下往上扫描
If r(j + 1) < r(j) Then '交换
t = r(j)
r(j) = r(j + 1)
r(j + 1) = t
noswap = False
End If
Next
If noswap Then Exit For '本趟排序中未发生交换则终止算法
Next
End Sub
'快速排序：
'划分：
Function partition(r, l, h)
Dim i, j, t
i = l
j = h
t = r(i) '初始化，t为基准
Do
While r(j) >= t And i < j
j = j - 1 '从右向左扫描，查找第1个小于t的数
Wend
If i < j Then
r(i) = r(j) '交换r(i)和r(j)
i = i + 1
End If
While r(i) <= t And i < j
i = i + 1 '从左向右扫描，查找第1个大于t的数
Wend
If i < j Then
r(j) = r(i) '交换r(i)和r(j)
j = j - 1
End If
Loop While i <> j
r(i) = t '基准t已被最后定位
partition = i
End Function
'选择排序：
Sub selectsort(r)
Dim i, n, k, j, t
n = UBound(r)
For i = 0 To n - 1 '做n趟排序
k = i
For j = i + 1 To n '在当前无序区选最小的数r(k)
If r(j) < r(k) Then k = j
Next
If k <> i Then
t = r(i)
r(i) = r(k)
r(k) = t
End If
Next
End Sub
'堆排序：
'筛选：
Sub sift(r, i, m) '以r(i)为根的完全二叉树构成堆
Dim t, j
t = r(i)
j = 2 * i
Do While j <= m 'j<=m,r(2*i)是r(i)的左孩子
If j < m Then
If r(j) < r(j + 1) Then j = j + 1 'j指向r(i)的右孩子
End If
If t < r(j) Then '孩子节点的数较大
r(i) = r(j) '将r(j)换到双亲位置上
i = j '修改当前被调整节点
j = 2 * i
Else
Exit Do '调整完毕，退出循环
End If
Loop
r(i) = t '最初被调整节点放入正确位置
End Sub
Sub heapsort(r)
Dim i, n, t
n = UBound(r)
For i = Fix(n / 2) To 0 Step -1 '建初始堆
sift r, i, n
Next
For i = n To 0 Step -1 '进行n+1趟排序
t = r(0) '当前堆顶数和最后一个数交换
r(0) = r(i)
r(i) = t
sift r, 0, i - 1 'r(0)到r(i-1)重建成堆
Next
End Sub |
|
IP卡
狗仔卡
显身卡
发表于 2023-2-10 08:05