Comment trier les tableaux à l'aide de vbscript?

Question

La question dit tout vraiment, mais ...

Je parcours un fichier à la recherche de lignes correspondant à un certain motif d'expression régulière, puis je souhaite imprimer les lignes qui correspondent mais dans l'ordre alphabétique. Je suis sûr que c'est trivial mais vbscript n'est pas mon fond

mon tableau est défini comme

Dim lines(10000)

si cela fait une différence, et j'essaie d'exécuter mon script à partir d'une invite de commande normale

merci

Answer 1

De Microsoft

Le tri des tableaux dans VBScript n'a jamais été facile. C’est parce que VBScript n’a aucune sorte de commande de tri. À son tour, cela signifiait toujours que les scripteurs VBScript étaient obligés d'écrire leurs propres routines de tri, qu'il s'agisse d'une routine de tri à bulle, d'un tri dans le tas, d'un tri rapide ou d'un autre type d'algorithme de tri.

Donc (en utilisant .Net tel qu’il est installé sur mon PC):

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

Je sais que c'est un sujet assez ancien, mais il pourrait être utile à tout le monde à l'avenir. le script ci-dessous fait ce que le type essayait de réaliser uniquement en utilisant vbscript. les termes commençant par une majuscule auront la priorité.

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

Les jeux d'enregistrements déconnectés peuvent être utiles.

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

Voici un QuickSort que j'ai écrit pour les tableaux renvoyés par la méthode GetRows de 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

Si vous voulez quand même afficher les lignes, vous pouvez exécuter la sortie via la commande de tri. Pas élégant, mais cela ne demande pas beaucoup de travail:

cscript.exe //nologo YOUR-SCRIPT | Sort

Remarque // nologo omet les lignes de logo (version d'hôte de script Windows Microsoft... blah blah blah) de s'afficher au milieu de la sortie triée. (Je suppose que MS ne sait pas à quoi sert stderr.)

Voir http://ss64.com/nt/sort.html pour plus de détails sur le tri.

/ + n est l'option la plus utile si votre clé de tri ne commence pas dans la première colonne.

Les comparaisons sont toujours insensibles à la casse, ce qui est nul.

Answer 6

Voici une autre implémentation vbscript de quicksort. C'est l'approche in-situ et instable telle que définie dans wikipedia (voir ici: http://en.wikipedia.org/wiki/Quicksort ). Utilise beaucoup moins de mémoire (la mise en œuvre initiale nécessite la création de matrices de stockage temporaire supérieure et inférieure à chaque itération, ce qui peut augmenter la taille de la mémoire de n termes dans le pire des cas).

Pour un ordre croissant, changez les signes. 

Si vous voulez trier les caractères, utilisez la fonction 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

Lorsque vous avez de grands tableaux ("larges"), au lieu de déplacer chaque élément d'une longue rangée de données, utilisez un tableau unidimensionnel avec les index du tableau.

initialiser ptr_arr avec 0,1,2,3, .. uBound (arr) puis accéder aux données avec 

arr(field_index,ptr_arr(row_index))

au lieu de

arr(field_index,row_index)

et juste échanger les éléments de ptr_arr au lieu d’échanger les lignes.

Si vous traitez le tableau ligne par ligne, par exemple en l'affichant en tant que, vous pouvez retirer le point de vue de la boucle interne:

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 8

Vous devez soit écrire votre propre sorte à la main, soit essayer cette technique: 

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

Vous pouvez librement mélanger javascript côté serveur avec VBScript. Ainsi, si VBScript vous manque, passez à javascript.

Answer 9

VBScript n'a pas de méthode pour trier les tableaux, vous avez donc deux options:

• Écrire une fonction de tri comme mergesort, à partir de zéro.
• Utilisez le conseil JScript de cet article

Answer 10

Un peu de tri à l'ancienne école. Bien sûr, cela ne trie que les tableaux à une seule dimension.

'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

Answer 11

Ceci est une implémentation vbscript de type fusion. 

'@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