Как отсортировать массивы с помощью vbscript?

Question

Вопрос говорит сам за себя, но ...

Я сканирую файл, ища строки, которые соответствуют определенному шаблону регулярных выражений, и затем я хочу распечатать строки, которые соответствуют, но в алфавитном порядке. Я уверен, что это тривиально, но VBScript не мой фон

мой массив определен как

Dim lines(10000)

если это что-то меняет, и я пытаюсь выполнить свой скрипт из обычного приглашения cmd

спасибо

Answer 1

С Майкрософт

Сортировка массивов в VBScript никогда не была простой; Это потому, что в VBScript нет команды сортировки. В свою очередь, это всегда означало, что сценаристы VBScript были вынуждены написать свои собственные процедуры сортировки, будь то процедура пузырьковой сортировки, сортировка в куче, быстрая сортировка или какой-либо другой тип алгоритма сортировки.

Итак (используя .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

Answer 2

Я знаю, что это довольно старая тема, но она может пригодиться любому в будущем. скрипт ниже делает то, что парень пытался достичь, просто используя 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 

Answer 3

Отключенные наборы записей могут быть полезны.

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

Answer 4

Вот QuickSort, который я написал для массивов, возвращенных из метода GetRows ADODB.Recordset.

'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

Answer 5

Если вы все равно собираетесь выводить строки, вы можете запустить вывод с помощью команды сортировки. Не элегантно, но не требует большой работы:

cscript.exe //nologo YOUR-SCRIPT | Sort

Примечание // nologo опускает строки логотипа ( Microsoft (R) Windows Script Host Version ... бла-бла-бла) в середине отсортированного вывода. (Полагаю, MS не знает, для чего предназначен stderr.)

Подробнее о сортировке см. http://ss64.com/nt/sort.html.

/ + n - наиболее полезная опция, если ключ сортировки не начинается в первом столбце.

Сравнения всегда без учета регистра , что является хромой.

Answer 6

Вот еще одна реализация быстрой сортировки в VBScript. Это нестабильный подход на месте, как определено в Википедии (см. Здесь: http://en.wikipedia.org/wiki/Quicksort). Использует намного меньше памяти (оригинальная реализация требует, чтобы верхние и нижние временные массивы хранения создавались при каждой итерации, что может увеличить объем памяти в худшем случае).

В порядке возрастания поменяйте знаки.

Если вы хотите отсортировать символы, используйте функцию 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

Answer 7

Некоторая сортировка массивов старой школы. Конечно, это сортирует только одномерные массивы.

C: \ DropBox \ Автоматизация \ Библиотека \ 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

Answer 8

При наличии больших ("широких") массивов вместо перемещения каждого элемента длинного ряда данных используйте одномерный массив с индексами массива.

инициализировать ptr_arr с 0,1,2,3, .. uBound (обр) затем получить доступ к данным с помощью

arr(field_index,ptr_arr(row_index))

вместо

arr(field_index,row_index)

и просто поменяйте местами элементы ptr_arr вместо замены строк.

Если вы обрабатываете массив построчно, например, отображаете его как a, вы можете исключить внешний вид из внутреннего цикла:

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>" 

Answer 9

Это реализация 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

Answer 10

Мне просто нужно было сделать что-то похожее, но с 2D-массивом вчера. Я не настолько хорош в VBScript, и этот процесс действительно застрял у меня. Я обнаружил, что статьи здесь были очень хорошо написаны и помогли мне перейти к сортировке в vbscript.