春之风 熊木杏里理解:VB对数字/字符数组的快速排序.查找. .
- '
- '数值与数组操作'
- 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