vbscript - vbscriptを使用して配列を並べ替えるにはどうすればよいですか？

Question

ファイルをスキャンして特定の正規表現パターンに一致する行を探しています。次に、一致する行をアルファベット順に印刷します。これは些細なことだと思いますが、vbscriptは私のバックグラウンドではありません

私の配列は次のように定義されています

Dim lines(10000)

それが何か違いを生む場合、そして私は通常のcmdプロンプトからスクリプトを実行しようとしています

score 45 · Accepted Answer

マイクロソフトから

VBScriptでの配列の並べ替えはかつてないほど簡単になりました。これは、VBScriptにはどのような種類の並べ替えコマンドもないためです。つまり、VBScriptスクリプト作成者は、バブルソートルーチン、ヒープソート、クイックソート、またはその他の種類のソートアルゴリズムなど、独自のソートルーチンを作成する必要がありました。

したがって（私のPCにインストールされている.Netを使用）：

Set outputLines = CreateObject("System.Collections.ArrayList")

'add lines
outputLines.Add output
outputLines.Add output

outputLines.Sort()
For Each outputLine in outputLines
    stdout.WriteLine outputLine
Next

score 23 · Accepted Answer

これはかなり古いトピックであることは知っていますが、将来誰にとっても役立つかもしれません。以下のスクリプトは、純粋に vbscript を使用して実現しようとしていたことを実行します。大文字で始まるソートされた用語が優先される場合。

for a = UBound(ArrayOfTerms) - 1 To 0 Step -1
    for j= 0 to a
        if ArrayOfTerms(j)>ArrayOfTerms(j+1) then
            temp=ArrayOfTerms(j+1)
            ArrayOfTerms(j+1)=ArrayOfTerms(j)
            ArrayOfTerms(j)=temp
        end if
    next
next

score 11 · Accepted Answer

切断されたレコードセットが役立つ場合があります。

Const adVarChar = 200  'the SQL datatype is varchar

'Create a disconnected recordset
Set rs = CreateObject("ADODB.RECORDSET")
rs.Fields.append "SortField", adVarChar, 25

rs.CursorType = adOpenStatic
rs.Open
rs.AddNew "SortField", "Some data"
rs.Update
rs.AddNew "SortField", "All data"
rs.Update

rs.Sort = "SortField"

rs.MoveFirst

Do Until rs.EOF
    strList=strList & vbCrLf & rs.Fields("SortField")        
    rs.MoveNext
Loop 

MsgBox strList

score 3 · Accepted Answer

これは、ADODB.Recordset の GetRows メソッドから返される配列用に作成した QuickSort です。

'Author:        Eric Weilnau
'Date Written:  7/16/2003
'Description:   QuickSortDataArray sorts a data array using the QuickSort algorithm.
'               Its arguments are the data array to be sorted, the low and high
'               bound of the data array, the integer index of the column by which the
'               data array should be sorted, and the string "asc" or "desc" for the
'               sort order.
'
Sub QuickSortDataArray(dataArray, loBound, hiBound, sortField, sortOrder)
    Dim pivot(), loSwap, hiSwap, count
    ReDim pivot(UBound(dataArray))

    If hiBound - loBound = 1 Then
        If (sortOrder = "asc" and dataArray(sortField,loBound) > dataArray(sortField,hiBound)) or (sortOrder = "desc" and dataArray(sortField,loBound) < dataArray(sortField,hiBound)) Then
            Call SwapDataRows(dataArray, hiBound, loBound)
        End If
    End If

    For count = 0 to UBound(dataArray)
        pivot(count) = dataArray(count,int((loBound + hiBound) / 2))
        dataArray(count,int((loBound + hiBound) / 2)) = dataArray(count,loBound)
        dataArray(count,loBound) = pivot(count)
    Next

    loSwap = loBound + 1
    hiSwap = hiBound

    Do
        Do While (sortOrder = "asc" and dataArray(sortField,loSwap) <= pivot(sortField)) or sortOrder = "desc" and (dataArray(sortField,loSwap) >= pivot(sortField))
            loSwap = loSwap + 1

            If loSwap > hiSwap Then
                Exit Do
            End If
        Loop

        Do While (sortOrder = "asc" and dataArray(sortField,hiSwap) > pivot(sortField)) or (sortOrder = "desc" and dataArray(sortField,hiSwap) < pivot(sortField))
            hiSwap = hiSwap - 1
        Loop

        If loSwap < hiSwap Then
            Call SwapDataRows(dataArray,loSwap,hiSwap)
        End If
    Loop While loSwap < hiSwap

    For count = 0 to Ubound(dataArray)
        dataArray(count,loBound) = dataArray(count,hiSwap)
        dataArray(count,hiSwap) = pivot(count)
    Next

    If loBound < (hiSwap - 1) Then
        Call QuickSortDataArray(dataArray, loBound, hiSwap-1, sortField, sortOrder)
    End If

    If (hiSwap + 1) < hiBound Then
        Call QuickSortDataArray(dataArray, hiSwap+1, hiBound, sortField, sortOrder)
    End If
End Sub

score 2 · Accepted Answer

古い学校の配列の並べ替え。もちろん、これは一次元配列のみをソートします。

'C:\DropBox\Automation\Libraries\Array.vbs

Option Explicit

Public Function Array_AdvancedBubbleSort(ByRef rarr_ArrayToSort(), ByVal rstr_SortOrder)
'   ==================================================================================
'   Date            : 12/09/1999
'   Author          : Christopher J. Scharer (CJS)
'   Description     : Creates a sorted Array from a one dimensional array
'                       in Ascending (default) or Descending order based on the rstr_SortOrder.
'   Variables       :
'                   rarr_ArrayToSort()     The array to sort and return.
'                   rstr_SortOrder   The order to sort in, default ascending or D for descending.
'   ==================================================================================
    Const const_FUNCTION_NAME = "Array_AdvancedBubbleSort"
    Dim bln_Sorted
    Dim lng_Loop_01
    Dim str_SortOrder
    Dim str_Temp

    bln_Sorted = False
    str_SortOrder = Left(UCase(rstr_SortOrder), 1) 'We only need to know if the sort order is A(SENC) or D(ESEND)...and for that matter we really only need to know if it's D because we are defaulting to Ascending.
    Do While (bln_Sorted = False)
       bln_Sorted = True
        str_Temp = ""
        If (str_SortOrder = "D") Then
            'Sort in descending order.
            For lng_Loop_01 = LBound(rarr_ArrayToSort) To (UBound(rarr_ArrayToSort) - 1)
                If (rarr_ArrayToSort(lng_Loop_01) < rarr_ArrayToSort(lng_Loop_01 + 1)) Then
                    bln_Sorted = False
                    str_Temp = rarr_ArrayToSort(lng_Loop_01)
                    rarr_ArrayToSort(lng_Loop_01) = rarr_ArrayToSort(lng_Loop_01 + 1)
                    rarr_ArrayToSort(lng_Loop_01 + 1) = str_Temp
                End If
                If (rarr_ArrayToSort((UBound(rarr_ArrayToSort) - 1) - (lng_Loop_01 - 1)) > rarr_ArrayToSort((UBound(rarr_ArrayToSort) - 1) - lng_Loop_01)) Then
                    bln_Sorted = False
                    str_Temp = rarr_ArrayToSort((UBound(rarr_ArrayToSort) - 1) - (lng_Loop_01 - 1))
                    rarr_ArrayToSort((UBound(rarr_ArrayToSort) - 1) - (lng_Loop_01 - 1)) = rarr_ArrayToSort((UBound(rarr_ArrayToSort) - 1) - lng_Loop_01)
                    rarr_ArrayToSort((UBound(rarr_ArrayToSort) - 1) - lng_Loop_01) = str_Temp
                End If
            Next
        Else
            'Default to Ascending.
            For lng_Loop_01 = LBound(rarr_ArrayToSort) To (UBound(rarr_ArrayToSort) - 1)
                If (rarr_ArrayToSort(lng_Loop_01) > rarr_ArrayToSort(lng_Loop_01 + 1)) Then
                    bln_Sorted = False
                    str_Temp = rarr_ArrayToSort(lng_Loop_01)
                    rarr_ArrayToSort(lng_Loop_01) = rarr_ArrayToSort(lng_Loop_01 + 1)
                    rarr_ArrayToSort(lng_Loop_01 + 1) = str_Temp
                End If
                If (rarr_ArrayToSort((UBound(rarr_ArrayToSort) - 1) - (lng_Loop_01 - 1)) < rarr_ArrayToSort((UBound(rarr_ArrayToSort) - 1) - lng_Loop_01)) Then
                    bln_Sorted = False
                    str_Temp = rarr_ArrayToSort((UBound(rarr_ArrayToSort) - 1) - (lng_Loop_01 - 1))
                    rarr_ArrayToSort((UBound(rarr_ArrayToSort) - 1) - (lng_Loop_01 - 1)) = rarr_ArrayToSort((UBound(rarr_ArrayToSort) - 1) - lng_Loop_01)
                    rarr_ArrayToSort((UBound(rarr_ArrayToSort) - 1) - lng_Loop_01) = str_Temp
                End If
            Next
        End If
    Loop
End Function

Public Function Array_BubbleSort(ByRef rarr_ArrayToSort())
'   ==================================================================================
'   Date            : 03/18/2008
'   Author          : Christopher J. Scharer (CJS)
'   Description     : Sorts an array.
'   ==================================================================================
    Const const_FUNCTION_NAME = "Array_BubbleSort"
    Dim lng_Loop_01
    Dim lng_Loop_02
    Dim var_Temp

    For lng_Loop_01 = (UBound(rarr_ArrayToSort) - 1) To 0 Step -1
        For lng_Loop_02 = 0 To lng_Loop_01
            If rarr_ArrayToSort(lng_Loop_02) > rarr_ArrayToSort(lng_Loop_02 + 1) Then
                var_Temp = rarr_ArrayToSort(lng_Loop_02 + 1)
                rarr_ArrayToSort(lng_Loop_02 + 1) = rarr_ArrayToSort(lng_Loop_02)
                rarr_ArrayToSort(lng_Loop_02) = var_Temp
            End If
        Next
    Next
End Function

Public Function Array_GetDimensions(ByVal rarr_Array)
    Const const_FUNCTION_NAME = "Array_GetDimensions"
    Dim int_Dimensions
    Dim int_Result
    Dim str_Dimensions

    int_Result = 0
    If IsArray(rarr_Array) Then
        On Error Resume Next
        Do
            int_Dimensions = -2
            int_Dimensions = UBound(rarr_Array, int_Result + 1)
            If int_Dimensions > -2 Then
                int_Result = int_Result + 1
                If int_Result = 1 Then
                    str_Dimensions = str_Dimensions & int_Dimensions
                Else
                    str_Dimensions = str_Dimensions & ":" & int_Dimensions
                End If
            End If
        Loop Until int_Dimensions = -2
        On Error GoTo 0
    End If
    Array_GetDimensions = int_Result ' & ";" & str_Dimensions
End Function

Public Function Array_GetUniqueCombinations(ByVal rarr_Fields, ByRef robj_Combinations)
    Const const_FUNCTION_NAME = "Array_GetUniqueCombinations"
    Dim int_Element
    Dim str_Combination

    On Error Resume Next

    Array_GetUniqueCombinations = CBool(False)
    For int_Element = LBound(rarr_Fields) To UBound(rarr_Fields)
        str_Combination = rarr_Fields(int_Element)
        Call robj_Combinations.Add(robj_Combinations.Count & ":" & str_Combination, 0)
'        Call Array_GetUniqueCombinationsSub(rarr_Fields, robj_Combinations, int_Element)
    Next 'int_Element
    For int_Element = LBound(rarr_Fields) To UBound(rarr_Fields)
        Call Array_GetUniqueCombinationsSub(rarr_Fields, robj_Combinations, int_Element)
    Next 'int_Element
    Array_GetUniqueCombinations = CBool(True)
End Function 'Array_GetUniqueCombinations

Public Function Array_GetUniqueCombinationsSub(ByVal rarr_Fields, ByRef robj_Combinations, ByRef rint_LBound)
    Const const_FUNCTION_NAME = "Array_GetUniqueCombinationsSub"
    Dim int_Element
    Dim str_Combination

    On Error Resume Next

    Array_GetUniqueCombinationsSub = CBool(False)
    str_Combination = rarr_Fields(rint_LBound)
    For int_Element = (rint_LBound + 1) To UBound(rarr_Fields)
        str_Combination = str_Combination & "," & rarr_Fields(int_Element)
        Call robj_Combinations.Add(robj_Combinations.Count & ":" & str_Combination, str_Combination)
    Next 'int_Element
    Array_GetUniqueCombinationsSub = CBool(True)
End Function 'Array_GetUniqueCombinationsSub

Public Function Array_HeapSort(ByRef rarr_ArrayToSort())
'   ==================================================================================
'   Date            : 03/18/2008
'   Author          : Christopher J. Scharer (CJS)
'   Description     : Sorts an array.
'   ==================================================================================
    Const const_FUNCTION_NAME = "Array_HeapSort"
    Dim lng_Loop_01
    Dim var_Temp
    Dim arr_Size

    arr_Size = UBound(rarr_ArrayToSort) + 1
    For lng_Loop_01 = ((arr_Size / 2) - 1) To 0 Step -1
        Call Array_SiftDown(rarr_ArrayToSort, lng_Loop_01, arr_Size)
    Next
    For lng_Loop_01 = (arr_Size - 1) To 1 Step -1
        var_Temp = rarr_ArrayToSort(0)
        rarr_ArrayToSort(0) = rarr_ArrayToSort(lng_Loop_01)
        rarr_ArrayToSort(lng_Loop_01) = var_Temp
        Call Array_SiftDown(rarr_ArrayToSort, 0, (lng_Loop_01 - 1))
    Next
End Function

Public Function Array_InsertionSort(ByRef rarr_ArrayToSort())
'   ==================================================================================
'   Date            : 03/18/2008
'   Author          : Christopher J. Scharer (CJS)
'   Description     : Sorts an array.
'   ==================================================================================
    Const const_FUNCTION_NAME = "Array_InsertionSort"
    Dim lng_ElementCount
    Dim lng_Loop_01
    Dim lng_Loop_02
    Dim lng_Index

    lng_ElementCount = UBound(rarr_ArrayToSort) + 1
    For lng_Loop_01 = 1 To (lng_ElementCount - 1)
        lng_Index = rarr_ArrayToSort(lng_Loop_01)
        lng_Loop_02 = lng_Loop_01
        Do While lng_Loop_02 > 0
            If rarr_ArrayToSort(lng_Loop_02 - 1) > lng_Index Then
                rarr_ArrayToSort(lng_Loop_02) = rarr_ArrayToSort(lng_Loop_02 - 1)
                lng_Loop_02 = (lng_Loop_02 - 1)
            End If
        Loop
        rarr_ArrayToSort(lng_Loop_02) = lng_Index
    Next
End Function

Private Function Array_Merge(ByRef rarr_ArrayToSort(), ByRef rarr_ArrayTemp(), ByVal rlng_Left, ByVal rlng_MiddleIndex, ByVal rlng_Right)
'   ==================================================================================
'   Date            : 03/18/2008
'   Author          : Christopher J. Scharer (CJS)
'   Description     : Merges an array.
'   ==================================================================================
    Const const_FUNCTION_NAME = "Array_Merge"
    Dim lng_Loop_01
    Dim lng_LeftEnd
    Dim lng_ElementCount
    Dim lng_TempPos

    lng_LeftEnd = (rlng_MiddleIndex - 1)
    lng_TempPos = rlng_Left
    lng_ElementCount = (rlng_Right - rlng_Left + 1)
    Do While (rlng_Left <= lng_LeftEnd) _
    And (rlng_MiddleIndex <= rlng_Right)
        If rarr_ArrayToSort(rlng_Left) <= rarr_ArrayToSort(rlng_MiddleIndex) Then
            rarr_ArrayTemp(lng_TempPos) = rarr_ArrayToSort(rlng_Left)
            lng_TempPos = (lng_TempPos + 1)
            rlng_Left = (rlng_Left + 1)
        Else
            rarr_ArrayTemp(lng_TempPos) = rarr_ArrayToSort(rlng_MiddleIndex)
            lng_TempPos = (lng_TempPos + 1)
            rlng_MiddleIndex = (rlng_MiddleIndex + 1)
        End If
    Loop
    Do While rlng_Left <= lng_LeftEnd
        rarr_ArrayTemp(lng_TempPos) = rarr_ArrayToSort(rlng_Left)
        rlng_Left = (rlng_Left + 1)
        lng_TempPos = (lng_TempPos + 1)
    Loop
    Do While rlng_MiddleIndex <= rlng_Right
        rarr_ArrayTemp(lng_TempPos) = rarr_ArrayToSort(rlng_MiddleIndex)
        rlng_MiddleIndex = (rlng_MiddleIndex + 1)
        lng_TempPos = (lng_TempPos + 1)
    Loop
    For lng_Loop_01 = 0 To (lng_ElementCount - 1)
        rarr_ArrayToSort(rlng_Right) = rarr_ArrayTemp(rlng_Right)
        rlng_Right = (rlng_Right - 1)
    Next
End Function

Public Function Array_MergeSort(ByRef rarr_ArrayToSort(), ByRef rarr_ArrayTemp(), ByVal rlng_FirstIndex, ByVal rlng_LastIndex)
'   ==================================================================================
'   Date            : 03/18/2008
'   Author          : Christopher J. Scharer (CJS)
'   Description     : Sorts an array.
'   Note            :The rarr_ArrayTemp array that is passed in has to be dimensionalized to the same size
'                           as the rarr_ArrayToSort array that is passed in prior to calling the function.
'                           Also the rlng_FirstIndex variable should be the value of the LBound(rarr_ArrayToSort)
'                           and the rlng_LastIndex variable should be the value of the UBound(rarr_ArrayToSort)
'   ==================================================================================
    Const const_FUNCTION_NAME = "Array_MergeSort"
    Dim lng_MiddleIndex

    If rlng_LastIndex > rlng_FirstIndex Then
        ' Recursively sort the two halves of the list.
        lng_MiddleIndex = ((rlng_FirstIndex + rlng_LastIndex) / 2)
        Call Array_MergeSort(rarr_ArrayToSort, rarr_ArrayTemp, rlng_FirstIndex, lng_MiddleIndex)
        Call Array_MergeSort(rarr_ArrayToSort, rarr_ArrayTemp, lng_MiddleIndex + 1, rlng_LastIndex)
        '  Merge the results.
        Call Array_Merge(rarr_ArrayToSort, rarr_ArrayTemp, rlng_FirstIndex, lng_MiddleIndex + 1, rlng_LastIndex)
    End If
End Function

Public Function Array_Push(ByRef rarr_Array, ByVal rstr_Value, ByVal rstr_Delimiter)
    Const const_FUNCTION_NAME = "Array_Push"
    Dim int_Loop
    Dim str_Array_01
    Dim str_Array_02

    'If there is no delimiter passed in then set the default delimiter equal to a comma.
    If rstr_Delimiter = "" Then
        rstr_Delimiter = ","
    End If

    'Check to see if the rarr_Array is actually an Array.
    If IsArray(rarr_Array) = True Then
        'Verify that the rarr_Array variable is only a one dimensional array.
        If Array_GetDimensions(rarr_Array) <> 1 Then
            Array_Push = "ERR, the rarr_Array variable passed in was not a one dimensional array."
            Exit Function
        End If
        If IsArray(rstr_Value) = True Then
            'Verify that the rstr_Value variable is is only a one dimensional array.
            If Array_GetDimensions(rstr_Value) <> 1 Then
                Array_Push = "ERR, the rstr_Value variable passed in was not a one dimensional array."
                Exit Function
            End If
            str_Array_01 = Split(rarr_Array, rstr_Delimiter)
            str_Array_02 = Split(rstr_Value, rstr_Delimiter)
            rarr_Array = Join(str_Array_01 & rstr_Delimiter & str_Array_02)
        Else
            On Error Resume Next
            ReDim Preserve rarr_Array(UBound(rarr_Array) + 1)
            If Err.Number <> 0 Then ' "Subscript out of range"  An array that was passed in must have been Erased to re-create it with new elements (possibly when passing an array to be populated into a recursive function)
                ReDim rarr_Array(0)
                Err.Clear
            End If
            If IsObject(rstr_Value) = True Then
                Set rarr_Array(UBound(rarr_Array)) = rstr_Value
            Else
                rarr_Array(UBound(rarr_Array)) = rstr_Value
            End If
        End If
    Else
        'Check to see if the rstr_Value is an Array.
        If IsArray(rstr_Value) = True Then
            'Verify that the rstr_Value variable is is only a one dimensional array.
            If Array_GetDimensions(rstr_Value) <> 1 Then
                Array_Push = "ERR, the rstr_Value variable passed in was not a one dimensional array."
                Exit Function
            End If
            rarr_Array = rstr_Value
        Else
            rarr_Array = Split(rstr_Value, rstr_Delimiter)
        End If
    End If
    Array_Push = UBound(rarr_Array)
End Function

Public Function Array_QuickSort(ByRef rarr_ArrayToSort(), ByVal rlng_Low, ByVal rlng_High)
'   ==================================================================================
'   Date            : 03/18/2008
'   Author          : Christopher J. Scharer (CJS)
'   Description     : Sorts an array.
'   Note            :The rlng_Low variable should be the value of the LBound(rarr_ArrayToSort)
'                           and the rlng_High variable should be the value of the UBound(rarr_ArrayToSort)
'   ==================================================================================
    Const const_FUNCTION_NAME = "Array_QuickSort"
    Dim var_Pivot
    Dim lng_Swap
    Dim lng_Low
    Dim lng_High

    lng_Low = rlng_Low
    lng_High = rlng_High
    var_Pivot = rarr_ArrayToSort((rlng_Low + rlng_High) / 2)
    Do While lng_Low <= lng_High
        Do While (rarr_ArrayToSort(lng_Low) < var_Pivot _
        And lng_Low < rlng_High)
            lng_Low = lng_Low + 1
        Loop
        Do While (var_Pivot < rarr_ArrayToSort(lng_High) _
        And lng_High > rlng_Low)
            lng_High = (lng_High - 1)
        Loop
        If lng_Low <= lng_High Then
            lng_Swap = rarr_ArrayToSort(lng_Low)
            rarr_ArrayToSort(lng_Low) = rarr_ArrayToSort(lng_High)
            rarr_ArrayToSort(lng_High) = lng_Swap
            lng_Low = (lng_Low + 1)
            lng_High = (lng_High - 1)
        End If
    Loop
    If rlng_Low < lng_High Then
        Call Array_QuickSort(rarr_ArrayToSort, rlng_Low, lng_High)
    End If
    If lng_Low < rlng_High Then
        Call Array_QuickSort(rarr_ArrayToSort, lng_Low, rlng_High)
    End If
End Function

Public Function Array_SelectionSort(ByRef rarr_ArrayToSort())
'   ==================================================================================
'   Date            : 03/18/2008
'   Author          : Christopher J. Scharer (CJS)
'   Description     : Sorts an array.
'   ==================================================================================
    Const const_FUNCTION_NAME = "Array_SelectionSort"
    Dim lng_ElementCount
    Dim lng_Loop_01
    Dim lng_Loop_02
    Dim lng_Min
    Dim var_Temp

    lng_ElementCount = UBound(rarr_ArrayToSort) + 1
    For lng_Loop_01 = 0 To (lng_ElementCount - 2)
        lng_Min = lng_Loop_01
        For lng_Loop_02 = (lng_Loop_01 + 1) To lng_ElementCount - 1
            If rarr_ArrayToSort(lng_Loop_02) < rarr_ArrayToSort(lng_Min) Then
            lng_Min = lng_Loop_02
            End If
        Next
        var_Temp = rarr_ArrayToSort(lng_Loop_01)
        rarr_ArrayToSort(lng_Loop_01) = rarr_ArrayToSort(lng_Min)
        rarr_ArrayToSort(lng_Min) = var_Temp
    Next
End Function

Public Function Array_ShellSort(ByRef rarr_ArrayToSort())
'   ==================================================================================
'   Date            : 03/18/2008
'   Author          : Christopher J. Scharer (CJS)
'   Description     : Sorts an array.
'   ==================================================================================
    Const const_FUNCTION_NAME = "Array_ShellSort"
    Dim lng_Loop_01
    Dim var_Temp
    Dim lng_Hold
    Dim lng_HValue

    lng_HValue = LBound(rarr_ArrayToSort)
    Do
        lng_HValue = (3 * lng_HValue + 1)
    Loop Until lng_HValue > UBound(rarr_ArrayToSort)
    Do
        lng_HValue = (lng_HValue / 3)
        For lng_Loop_01 = (lng_HValue + LBound(rarr_ArrayToSort)) To UBound(rarr_ArrayToSort)
            var_Temp = rarr_ArrayToSort(lng_Loop_01)
            lng_Hold = lng_Loop_01
            Do While rarr_ArrayToSort(lng_Hold - lng_HValue) > var_Temp
                rarr_ArrayToSort(lng_Hold) = rarr_ArrayToSort(lng_Hold - lng_HValue)
                lng_Hold = (lng_Hold - lng_HValue)
                If lng_Hold < lng_HValue Then
                    Exit Do
                End If
            Loop
            rarr_ArrayToSort(lng_Hold) = var_Temp
        Next
    Loop Until lng_HValue = LBound(rarr_ArrayToSort)
End Function

Private Function Array_SiftDown(ByRef rarr_ArrayToSort(), ByVal rlng_Root, ByVal rlng_Bottom)
'   ==================================================================================
'   Date            : 03/18/2008
'   Author          : Christopher J. Scharer (CJS)
'   Description     : Sifts the elements down in an array.
'   ==================================================================================
    Const const_FUNCTION_NAME = "Array_SiftDown"
    Dim bln_Done
    Dim max_Child
    Dim var_Temp

    bln_Done = False
    Do While ((rlng_Root * 2) <= rlng_Bottom) _
    And bln_Done = False
        If rlng_Root * 2 = rlng_Bottom Then
            max_Child = (rlng_Root * 2)
        ElseIf rarr_ArrayToSort(rlng_Root * 2) > rarr_ArrayToSort(rlng_Root * 2 + 1) Then
            max_Child = (rlng_Root * 2)
        Else
            max_Child = (rlng_Root * 2 + 1)
        End If
        If rarr_ArrayToSort(rlng_Root) < rarr_ArrayToSort(max_Child) Then
            var_Temp = rarr_ArrayToSort(rlng_Root)
            rarr_ArrayToSort(rlng_Root) = rarr_ArrayToSort(max_Child)
            rarr_ArrayToSort(max_Child) = var_Temp
            rlng_Root = max_Child
        Else
            bln_Done = True
        End If
    Loop
End Function

score 1 · Accepted Answer

クイックソートの別のvbscript実装があります。これは、ウィキペディアで定義されているインプレースの不安定なアプローチです（http://en.wikipedia.org/wiki/Quicksortを参照）。使用するメモリははるかに少なくなります（元の実装では、反復ごとに上位および下位の一時ストレージアレイを作成する必要があり、最悪の場合、メモリサイズがn項増加する可能性があります）。

昇順の場合は、記号を切り替えます。

文字を並べ替える場合は、Asc（ch）関数を使用してください。

'-------------------------------------
 '  quicksort
 '    Carlos Nunez, created: 25 April, 2010.
 '
 '  NOTE:   partition function also
 '          required
 '-------------------------------------
function qsort(list, first, last)
    Dim i, j
    if (typeName(list) <> "Variant()" or ubound(list) = 0) then exit function       'list passed must be a collection or array.

    'if the set size is less than 3, we can do a simple comparison sort.
    if (last-first) < 3 then
        for i = first to last
            for j = first to last
                if list(i) < list(j) then
                    swap list,i,j
                end if
            next
        next
    else
        dim p_idx

        'we need to set the pivot relative to the position of the subset currently being sorted.
        'if the starting position of the subset is the first element of the whole set, then the pivot is the median of the subset.
        'otherwise, the median is offset by the first position of the subset.
        '-------------------------------------------------------------------------------------------------------------------------
        if first-1 < 0 then
            p_idx   = round((last-first)/2,0)
        else
            p_idx   = round(((first-1)+((last-first)/2)),0)
        end if

        dim p_nidx:     p_nidx  = partition(list, first, last, p_idx)
        if p_nidx = -1 then exit function

        qsort list, first, p_nidx-1
        qsort list, p_nidx+1, last
    end if
end function


function partition(list, first, last, idx)
    Dim i
    partition = -1

    dim p_val:      p_val = list(idx)
    swap list,idx,last
    dim swap_pos:   swap_pos = first
    for i = first to last-1 
        if list(i) <= p_val then
            swap list,i,swap_pos
            swap_pos = swap_pos + 1
        end if
    next
    swap list,swap_pos,last

    partition = swap_pos
end function

function swap(list,a_pos,b_pos)
    dim tmp
    tmp = list(a_pos)
    list(a_pos) = list(b_pos)
    list(b_pos) = tmp   
end function

score 1 · Accepted Answer

これは、マージソートの vbscript 実装です。

'@Function Name: Sort
'@Author: Lewis Gordon
'@Creation Date: 4/26/12
'@Description: Sorts a given array either in ascending or descending order, as specified by the
'                order parameter.  This array is then returned at the end of the function.
'@Prerequisites:  An array must be allocated and have all its values inputted.
'@Parameters:
'    $ArrayToSort:  This is the array that is being sorted.
'    $Order:  This is the sorting order that the array will be sorted in.  This parameter 
'                can either    be "ASC" or "DESC" or ascending and descending, respectively.
'@Notes:  This uses merge sort under the hood.  Also, this function has only been tested for
'            integers and strings in the array.  However, this should work for any data type that
'            implements the greater than and less than comparators.  This function also requires
'            that the merge function is also present, as it is needed to complete the sort.
'@Examples:
'    Dim i
'    Dim TestArray(50)
'    Randomize
'    For i=0 to UBound(TestArray)
'        TestArray(i) = Int((100 - 0 + 1) * Rnd + 0)
'    Next
'    MsgBox Join(Sort(TestArray, "DESC"))
'
'@Return value:  This function returns a sorted array in the specified order.
'@Change History: None

'The merge function.
Public Function Merge(LeftArray, RightArray, Order)
    'Declared variables
    Dim FinalArray
    Dim FinalArraySize
    Dim i
    Dim LArrayPosition
    Dim RArrayPosition

    'Variable initialization
    LArrayPosition = 0
    RArrayPosition = 0

    'Calculate the expected size of the array based on the two smaller arrays.
    FinalArraySize = UBound(LeftArray) + UBound(RightArray) + 1
    ReDim FinalArray(FinalArraySize)

    'This should go until we need to exit the function.
    While True

        'If we are done with all the values in the left array.  Add the rest of the right array
        'to the final array.
        If LArrayPosition >= UBound(LeftArray)+1 Then
            For i=RArrayPosition To UBound(RightArray)
                FinalArray(LArrayPosition+i) = RightArray(i)
            Next
            Merge = FinalArray
            Exit Function

        'If we are done with all the values in the right array.  Add the rest of the left array
        'to the final array.
        ElseIf RArrayPosition >= UBound(RightArray)+1 Then
            For i=LArrayPosition To UBound(LeftArray)
                FinalArray(i+RArrayPosition) = LeftArray(i)
            Next
            Merge = FinalArray
            Exit Function

        'For descending, if the current value of the left array is greater than the right array 
        'then add it to the final array.  The position of the left array will then be incremented
        'by one.
        ElseIf LeftArray(LArrayPosition) > RightArray(RArrayPosition) And UCase(Order) = "DESC" Then
            FinalArray(LArrayPosition+RArrayPosition) = LeftArray(LArrayPosition)
            LArrayPosition = LArrayPosition + 1

        'For ascending, if the current value of the left array is less than the right array 
        'then add it to the final array.  The position of the left array will then be incremented
        'by one.
        ElseIf LeftArray(LArrayPosition) < RightArray(RArrayPosition) And UCase(Order) = "ASC" Then
            FinalArray(LArrayPosition+RArrayPosition) = LeftArray(LArrayPosition)
            LArrayPosition = LArrayPosition + 1

        'For anything else that wasn't covered, add the current value of the right array to the
        'final array.
        Else
            FinalArray(LArrayPosition+RArrayPosition) = RightArray(RArrayPosition)
            RArrayPosition = RArrayPosition + 1
        End If
    Wend
End Function

'The main sort function.
Public Function Sort(ArrayToSort, Order)
    'Variable declaration.
    Dim i
    Dim LeftArray
    Dim Modifier
    Dim RightArray

    'Check to make sure the order parameter is okay.
    If Not UCase(Order)="ASC" And Not UCase(Order)="DESC" Then
        Exit Function
    End If
    'If the array is a singleton or 0 then it is sorted.
    If UBound(ArrayToSort) <= 0 Then
        Sort = ArrayToSort
        Exit Function
    End If

    'Setting up the modifier to help us split the array effectively since the round
    'functions aren't helpful in VBScript.
    If UBound(ArrayToSort) Mod 2 = 0 Then
        Modifier = 1
    Else
        Modifier = 0
    End If

    'Setup the arrays to about half the size of the main array.
    ReDim LeftArray(Fix(UBound(ArrayToSort)/2))
    ReDim RightArray(Fix(UBound(ArrayToSort)/2)-Modifier)

    'Add the first half of the values to one array.
    For i=0 To UBound(LeftArray)
        LeftArray(i) = ArrayToSort(i)
    Next

    'Add the other half of the values to the other array.
    For i=0 To UBound(RightArray)
        RightArray(i) = ArrayToSort(i+Fix(UBound(ArrayToSort)/2)+1)
    Next

    'Merge the sorted arrays.
    Sort = Merge(Sort(LeftArray, Order), Sort(RightArray, Order), Order)
End Function

score 0 · Accepted Answer

手作業で独自のソートを作成するか、次の手法を試す必要があります。

http://www.aspfaqs.com/aspfaqs/ShowFAQ.asp?FAQID=83

サーバー側のJavaScriptとVBScriptを自由に組み合わせることができるため、VBScriptが不足している場合は、JavaScriptに切り替えてください。

score 0 · Accepted Answer

VBScriptには配列を並べ替えるメソッドがないため、次の2つのオプションがあります。

マージソートのようなソート関数をゼロから作成します。
この記事のJScriptのヒントを使用してください

score 0 · Accepted Answer

大きな (「広い」) 配列がある場合、データの長い行の各要素を移動する代わりに、配列のインデックスを持つ 1 次元配列を使用します。

ptr_arr を 0,1,2,3,..uBound(arr) で初期化し、次にデータにアクセスします

arr(field_index,ptr_arr(row_index))

それ以外の

arr(field_index,row_index)

行を交換する代わりに、 ptr_arr の要素を交換するだけです。

配列を行ごとに処理している場合、たとえばとして表示している場合は、内側のループから目を離すことができます。

max_col=uBound(arr,1)
response.write "<table>"
for n = 0 to uBound(arr,2)
  response.write "<tr>"
  row=ptr_arr(n)
  for i=0 to max_col
    response.write "<td>"&arr(i,row)&"</td>"
  next
  response.write "</tr>
next
response.write "</table>"

score -2 · Accepted Answer

私は実際に同じようなことをしなければなりませんでしたが、昨日は2D配列を使用しました。私はvbscriptのスピードにそれほど慣れておらず、このプロセスは本当に私を困惑させました。ここの記事は非常によく書かれていることがわかり、vbscriptでの並べ替えへの道を歩み始めました。

vbscript - vbscriptを使用して配列を並べ替えるにはどうすればよいですか？

13 に答える 13

Related

Reference