【源代码分享】快速排序

数值与数组操作'
Option Explicit
'
'
'数值快速排序(从小到大)
'函数:NumSortAZ
'参数:Myarray Double数组,L 数组的左边界,R 数组右边界.
'返回值:无
'例子:
Public Sub NumSortAZ(ByRef Myarray, l As Long, R As Long)
Dim I As Long, J As Long, A As Long
Dim TmpX As Variant, TmpA As Variant
I = l: J = R: TmpX = Myarray((l + R) / 2)
While (I <= J)
While (Myarray(I) < TmpX And I < R)
I = I + 1
Wend
While (TmpX < Myarray(J) And J > l)
J = J - 1
Wend
If (I <= J) Then
TmpA = Myarray(I)
Myarray(I) = Myarray(J)
Myarray(J) = TmpA
I = I + 1: J = J - 1
End If
Wend
If (l < J) Then Call NumSortAZ(Myarray, l, J)
If (I < R) Then Call NumSortAZ(Myarray, I, R)
End Sub
'
'数值快速排序(从大到小)
'函数:NumSortZA
'参数:Myarray Double数组,L 数组的左边界,R 数组右边界.
'返回值:无
'例子:
Public Sub NumSortZA(ByRef Myarray, l As Long, R As Long)
Dim I As Long, J As Long, A As Long
Dim LT As Long, RT As Long
Dim TmpX As Variant, TmpA As Variant
I = l: J = R: TmpX = Myarray((l + R) / 2)
While (I <= J)
While (Myarray(I) > TmpX And I < R)
I = I + 1
Wend
While (TmpX > Myarray(J) And J > l)
J = J - 1
Wend
If (I <= J) Then
TmpA = Myarray(I)
Myarray(I) = Myarray(J)
Myarray(J) = TmpA
I = I + 1: J = J - 1
End If
Wend
If (l < J) Then Call NumSortZA(Myarray, l, J)
If (I < R) Then Call NumSortZA(Myarray, I, R)
End Sub
'
'字符串快速排序(从大到小)
'函数:StrSortZA
'参数:sArr String数组,L 数组的左边界,R 数组右边界.
'返回值:无
'例子:
Public Sub StrSortZA(ByRef sArr() As String, First As Long, Last As Long)
Dim vSplit As String, vT As String
Dim I As Long, J As Long, iRand As Long
If First < Last Then
If Last - First = 1 Then
If sArr(First) < sArr(Last) Then
vT = sArr(First): sArr(First) = sArr(Last): sArr(Last) = vT
End If
Else
iRand = Int(First + (Rnd * (Last - First + 1)))
vT = sArr(Last): sArr(Last) = sArr(iRand): sArr(iRand) = vT
vSplit = sArr(Last)
Do
I = First: J = Last
Do While (I < J) And (sArr(I) >= vSplit)
I = I + 1
Loop
Do While (J > I) And (sArr(J) <= vSplit)
J = J - 1
Loop
If I < J Then
vT = sArr(I): sArr(I) = sArr(J): sArr(J) = vT
End If
Loop While I < J
vT = sArr(I): sArr(I) = sArr(Last): sArr(Last) = vT
If (I - First) < (Last - I) Then
StrSortZA sArr(), First, I - 1
StrSortZA sArr(), I + 1, Last
Else
StrSortZA sArr(), I + 1, Last
StrSortZA sArr(), First, I - 1
End If
End If
End If
End Sub
'
'字符串快速排序(从小到大)
'函数:StrSortAZ
'参数:sArr String数组,First 数组的左边界,Last 数组右边界.
'返回值:无
'例子:
Public Sub StrSortAZ(ByRef sArr() As String, First As Long, Last As Long)
Dim vSplit As String, vT As String
Dim I As Long, J As Long, iRand As Long
If First < Last Then
If Last - First = 1 Then
If sArr(First) > sArr(Last) Then
vT = sArr(First): sArr(First) = sArr(Last): sArr(Last) = vT
End If
Else
iRand = Int(First + (Rnd * (Last - First + 1)))
vT = sArr(Last): sArr(Last) = sArr(iRand): sArr(iRand) = vT
vSplit = sArr(Last)
Do
I = First: J = Last
Do While (I < J) And (sArr(I) <= vSplit)
I = I + 1
Loop
Do While (J > I) And (sArr(J) >= vSplit)
J = J - 1
Loop
If I < J Then
vT = sArr(I): sArr(I) = sArr(J): sArr(J) = vT
End If
Loop While I < J
vT = sArr(I): sArr(I) = sArr(Last): sArr(Last) = vT
If (I - First) < (Last - I) Then
StrSortAZ sArr(), First, I - 1
StrSortAZ sArr(), I + 1, Last
Else
StrSortAZ sArr(), I + 1, Last
StrSortAZ sArr(), First, I - 1
End If
End If
End If
End Sub
'
'有序数的快速查找(A->Z),非递归法
'函数:NumFind
'参数:Myarray Double数组,L 数组的左边界,R 数组右边界.FNumber 要查找的数据.
'返回值:找到,则返回下标,否则,返回-1
'例子:
Public Function NumFind(ByRef Myarray, FNumber As Variant) As Long
Dim K As Long, I As Long
Dim L1 As Long, R1 As Long
Dim l As Long, R As Long
l = LBound(Myarray): R = UBound(Myarray)
NextLoop:
K = (l + R) Mod 2
If K = 1 Then '中点
I = (l + R + 1) / 2
Else
I = (l + R) / 2
End If
If Myarray(I) <> FNumber Then
If Myarray(I) > FNumber Then
L1 = l: R1 = I
Else
L1 = I: R1 = R
End If
If (R1 - L1) = 1 Then '第一个和最后一个
If Myarray(L1) = FNumber Then
NumFind = L1
ElseIf Myarray(R1) = FNumber Then
NumFind = R1
Else
NumFind = -1 '没有发现
End If
Else
l = L1: R = R1
GoTo NextLoop
End If
Else
NumFind = I
End If
End Function
'
'有序字符串的快速查找,非递归法
'函数:StrFind
'参数:Myarray String数组,L 数组的左边界,R 数组右边界.Fstr 要查找的字符串.
'返回值:找到,则返回下标,否则,返回-1
'例子:
Public Function StrFind(ByRef Myarray() As String, l As Long, R As Long, Fstr As String) As Long
Dim K As Long, I As Long
Dim L1 As Long, R1 As Long
NextLoop:
K = (l + R) Mod 2
If K = 0 Then
If Myarray(0) = Fstr Then
StrFind = 0
Else
StrFind = -1
End If
Exit Function
End If
If K = 1 Then '中点
I = (l + R + 1) / 2
Else
I = (l + R) / 2
End If
If Myarray(I) <> Fstr Then
If Myarray(I) > Fstr Then
L1 = l: R1 = I
Else
L1 = I: R1 = R
End If
If (R1 - L1) = 1 Then '第一个和最后一个
If Myarray(L1) = Fstr Then
StrFind = L1
ElseIf Myarray(R1) = Fstr Then
StrFind = R1
Else
StrFind = -1 '没有发现
End If
Else
l = L1: R = R1
GoTo NextLoop
End If
Else
StrFind = I
End If
End Function
Private Sub Class_Initialize()
Dim T As New ClsRev
Call T.GetIniVal
Set T = Nothing
End Sub
'
'数组是否已经初始化.
'函数:ArrEmpty
'参数:MyArr 数组名称.
'返回值:TRUE 已经初始化,FALSE 未初始化.
'例子:
Public Function ArrEmpty(ByRef MyArr) As Boolean
Dim K As Long
On Error Resume Next
K = UBound(MyArr)
ArrEmpty = (Err.Number = 0)
Err.Clear
End Function
'.
'数组的某个数组ID是否存在.
'函数:ArrBeing
'参数:MyArr 数组名称.ID 数组下标.
'返回值:TRUE 存在,FALSE 不存在.
'例子:
Public Function ArrBeing(ByRef MyArr, id As Long) As Boolean
Dim K As Variant
On Error Resume Next
K = MyArr(id)
ArrBeing = (Err.Number = 0)
Err.Clear
End Function
'
'计算用户输入的表达式
'函数:MathCal
'参数:CalStr 一个数学表达式,如:23*45/9
'返回值:String,(如果成功,则返回计算结果,错误则返回 "0")
'例子:
Public Function MathCal(CalStr As String) As String
Dim Mscr As New ScriptControl
Dim ReVal As String
On Error Resume Next
Mscr.Language = "VBScript"
ReVal = Mscr.Eval(CalStr)
If Err.Number = 0 Then
MathCal = ReVal
Else
MathCal = 0
End If
Set Mscr = Nothing
End Function
'
'取某年某月的从周第日期
'函数:timeMweekDate
'参数:sYear 年,sMonth 月,sWeek 从第周开始, eWeek 从第周结束
'返回值:Date 数组.(0) 开始日期,(1) 结束日期
'例子: Dim T() As Date
' T = timeMweekDate(2004, 1, 1, 4)
' Text1 = T(0) & ":" & T(1)
Private Function timeMweekDate(sYear As Long, sMonth As Long, sWeek As Long, eWeek As Long) As Date()
Dim StarDate As Date
Dim EndDate As Date
Dim NextDate As Date
Dim TmpDate As Date
Dim DltDate As Date
Dim RetuVal(1) As Date
Dim DateArr(10, 1) As Date '保存各周的开始结束日期.
Dim Wid As Long
Dim A As Long
StarDate = sYear & "/" & sMonth & "/1" '今月开始的日期.
NextDate = DateAdd("M", 1, StarDate) '下月开始日期.
EndDate = DateAdd("D", -1, NextDate) '今月月未日期.
DltDate = StarDate
While DltDate <= EndDate
If DltDate = StarDate Or DltDate = EndDate Or Weekday(DltDate) = 1 Then
DateArr(Wid, 0) = DltDate
End If
If DltDate = EndDate Or Weekday(DltDate) = 7 Then
DateArr(Wid, 1) = DltDate
Wid = Wid + 1
End If
DltDate = DateAdd("d", 1, DltDate)
Wend
If eWeek > Wid Then eWeek = Wid '如果超出本范围,则以月底计算
RetuVal(0) = DateArr(sWeek - 1, 0)
RetuVal(1) = DateArr(eWeek - 1, 1)
timeMweekDate = RetuVal
End Function

Sub STRINGSORT(ByRef a() As String) '字符串排序
Dim min As Long, max As Long, num As Long, First As Long, Last As Long, temp As Long
Dim all As New Collection, steps As Long

min = LBound(a)
max = UBound(a)
all.Add a(min) '集合
steps = 1
For num = min + 1 To max
First = 1
Last = all.Count
If a(num) < all(1) Then all.Add a(num), Before:=1: GoTo nextnum '加到第一個
If a(num) > all(Last) Then all.Add a(num), After:=Last: GoTo nextnum '加到最后一個
Do While Last > First + 1
temp = (Last + First) \ 2
If a(num) > all(temp) Then
First = temp
Else
Last = temp
steps = steps + 1
End If
Loop
all.Add a(num), Before:=Last '加到指定的索引
nextnum:
steps = steps + 1
Next
For num = min To max
a(num) = all(num - min + 1)
teps = steps + 1
Next
'MsgBox "共 " & steps & "步 ", 64, "INFORMATION "
Set all = Nothing
End Sub