[问题求助] [已解决]请问纯 VBS 数组排序算法怎么写？（要求纯 VBS 无组件）

yu2n

请问纯 VBS 数组排序算法怎么写？（要求纯 VBS 无组件）

如何将数组中的字符串按从左到右、AscW()的大小升序排列？
排序前：

Array("ACE_OVER", "AC-012", "520", "淡淡的忧伤", "098", "小小")
复制代码

排序后

Array("098", "520", "AC-012", "ACE_OVER", "小小", "淡淡的忧伤")
复制代码

补充1：字符串暂限定长度为 256 。
补充2：如果支持中文拼音排序就更好了 ...

yu2n

贴个代码留念~

' 『表格字符串』指定列名、列号排序  by yu2n

' 指定列名(usr)排序：
' sn,usr,pwd
' 01,CCC,D00
' 02,BBB,E11
' 03,AAA,F22
' =>
' sn,usr,pwd
' 03,AAA,F22
' 02,BBB,E11
' 01,CCC,D00

' 指定列序号(2)排序：
' 01,CCC,D00
' 02,BBB,E11
' 03,AAA,F22
' =>
' 03,AAA,F22
' 02,BBB,E11
' 01,CCC,D00

Demo
Sub Demo()
  sField = "sn,usr,pwd"
  sContent = "01,CCC,D00" & vbCrLf _
          & "02,BBB,E11" & vbCrLf _
          & "03,AAA,F22"
  ' 指定列名排序
  sTable = sField & vbCrLf & sContent
  WScript.Echo "指定列名(usr)排序：" & vbCrLf & sTable & vbCrLf & "=>" _
    & vbCrLf & SortTableString(sTable, "usr", ",") & vbCrLf
  ' 指定列序号排序
  sTable = sContent
  WScript.Echo "指定列序号(2)排序：" & vbCrLf & sTable & vbCrLf & "=>" _
    & vbCrLf & SortTableString(sTable, 2, ",") & vbCrLf
End Sub

Function SortTableString(ByVal sTable, ByVal sField, ByVal sFlag)
  ' Format String
  sTable = Trim(sTable)
  If Left(sTable, 2) = vbCrLf Then sTable = Right(sTable, Len(sTable) - 2)
  If Right(sTable, 2) = vbCrLf Then sTable = Left(sTable, Len(sTable) - 2)
  If InStr(sTable, vbCrLf) < 1 Or InStr(sTable, sFlag) < 1 Then Exit Function
  ' init ...
  Dim arr(), arrRows, arrCols, nRowStart
  arrRows = Split(sTable, vbCrLf)
  If UBound(arrRows) = 0 Then Exit Function
  nRowStart = 0
  nRows = UBound(arrRows)
  nCols = UBound(Split(arrRows(0), sFlag))
  ReDim Preserve arr(nCols, nRows)
  For nRow = 0 To nRows
    arrCols = Split(arrRows(nRow), sFlag)
    For nCol = 0 To nCols
      ' Set Table
      arr(nCol, nRow) = arrCols(nCol)
      ' Get nField Index
      If nRow = 0 Then
        If sField = nCol + 1 Then nField = nCol
        If sField = arrCols(nCol) Then nField = nCol: nRowStart = 1
      End If
    Next
  Next
  ' Sort by Field_Index/Field_Name
  Dim i, j, tmp
  For i = nRowStart To nRows
    For j = i + 1 To nRows
      If CStr(arr(nField, i)) > CStr(arr(nField, j)) Then
        tmp = arrRows(i)
        arrRows(i) = arrRows(j)
        arrRows(j) = tmp
      End If
    Next
  Next
  ' Output
  SortTableString = Join(arrRows, vbCrLf)
End Function
复制代码

yu2n

回复 8# Demon

排序算法：冒泡排序
排序条件：字符串逐个字符按字符码(AscW函数)升序排序

方法1: CStr(字符串) 直接比较大小

方法2: 字符串 -> 拆分单个字符 
      -> 转16进制(Hex)表示
      -> 合并Hex字符串
      -> CStr(Hex字符串) 比较大小

方法3: 字符串 -> 拆分单个字符
      -> 计算单个字符的“权重”：AscW(Chr_) * 65536 ^ (最大字符串长度 - 当前字符位置)
      -> 累加单个字符的“权重”
      -> 比较累加后的字符串“权重”大小

Ps: 
方法1 使用 CStr() 直接达成排序条件，推荐使用。
      本人因为之前测试方法有误，测试失败就没采用 ... 后来测试CStr()可用。

方法2 应该可以在比较特殊的情况下使用。

方法3 “权重”数值太大，超范围会失效。不建议使用。
复制代码

Demon

沼跃鱼早已看穿了一切，却看不懂你们的算法。

yu2n

写了个冒泡的
话说和不用 str2hex 的结果没区别嘛...
不知道这样是不是按 Local 顺序排列的
CrLf 发表于 2015-1-16 00:08

简单测试了下，原来只用CStr()就可以比较大小，默认就是AcsW的排序了，看来是我想多了...

CrLf

回复 5# yu2n


    科学计数法不靠谱吧，受精度限制，只有头几个字是准的，后面就只保留位数了，给个反例：

arr = Array("ACE_OVER" & String(17, "_") & "AAA", "ACE_OVER" & String(20, "_"),"ACE_OVER" & String(17, "_") & "AAA")
复制代码

yu2n

放上我的解 ... 嗯 ... 支持64个中英文字符，超过64的，按64个算：

arr = Array("ACE_OVER" & String(999, "_"), "AC-012", "520", "淡淡的忧伤", "098", "小小")
arr2 = arr

For i = 0 To UBound(arr)
    For j = i + 1 To UBound(arr)
        If Summary(arr, i) > Summary(arr, j) Then
          t = arr(i)
          arr(i) = arr(j)
          arr(j) = t
        End If
    Next
Next

WScript.Echo Join(arr2, ", ") & vbCrLf & vbCrLf & "=>" & vbCrLf & vbCrLf & Join(arr, ", ")

Function Summary(ByVal arr, ByVal nIndex)
    nMaxLen = 64
    nLen = Len(arr(nIndex))
    If nLen > nMaxLen Then nLen = nMaxLen
    For n = 1 To nLen
      nCount = nCount + Abs(AscW(Mid(arr(nIndex), n, 1))) * (65535 ^ (nMaxLen - n))
    Next
    Summary = nCount
End Function
复制代码

Demon

我是来围观的

CrLf

如果不涉及字节操作，还是 js 好用啊

CrLf

写了个冒泡的
话说和不用 str2hex 的结果没区别嘛...
不知道这样是不是按 Local 顺序排列的

arr = Array("ACE_OVER", "AC-012", "-1","@fas" ,"520", "淡淡的忧伤", "098", "小小")

For i=0 To UBound(arr)
	arr(i) = str2hex(arr(i))
Next

For i=1 To UBound(arr)
	For j=i To 1 Step -1
		If CStr(arr(j))<CStr(arr(j-1)) Then
			tmp = arr(j)
			arr(j) = arr(j-1)
			arr(j-1) = tmp
		End If
	Next
Next

For i=0 To UBound(arr)
	WScript.Echo (arr(i))
	WScript.Echo hex2str(arr(i))
Next

Function str2hex(str)
	Dim i,char,arr()
	ReDim arr(Len(str))
	For i=1 To Len(str)
		char = Mid(str,i,1)
		If Asc(char)<0 Then
			arr(i-1) = char
		Else
			arr(i-1) = "\x" & Right("0" & Hex(Asc(char)),2)
		End If
	Next
	
	str2hex = Join(arr,"")	
End Function

Function hex2str(hexstr)
	Dim i
	For i=0 To 127
		If i <> 92 Then
			hexstr = Replace(hexstr,"\x" & Right("0" & Hex(i),2),Chr(i))
		End If
	Next
	
	hex2str = Replace(hexstr,"\x5c","\")
End Function
复制代码