Fonctions pour tableaux (array)

Commenter

Contenu du snippet

J'avais déjà posté quelques fonctions pratiques qui avaient pour but d'aider les manipulations de noms de fichiers (cf: FONCTIONS FICHIERS (FILE & PATH)).
Dans le même esprit, voici quelques fonctions qui me semblent intéressantes. Elles ont cette fois pour objet les arrays.

Source / Exemple : 


Option Explicit

Function SortNumbers(vArray As Variant) As Variant
    ' This function sorts a vector of Long Integers
    ' using the Shell Sort Methode.
    ' Source: http://vbnet.mvps.org/index.html?code/sort/qsvariations.htm
    Dim arr     As Variant
    Dim i       As Long
    Dim tmp     As Long
    Dim nHold   As Long
    Dim nHValue As Long
    Dim counter As Long
    ' temp array
    arr = vArray
    nHValue = LBound(arr)
    ' get biggest multipl.
    Do
       nHValue = 3 * nHValue + 1
    Loop Until nHValue > UBound(arr)
    ' loop thru numbers / sort
    Do
       nHValue = nHValue / 3
       For i = nHValue + LBound(arr) To UBound(arr)
          tmp = arr(i)
          nHold = i
          Do While arr(nHold - nHValue) > tmp
             arr(nHold) = arr(nHold - nHValue)
             nHold = nHold - nHValue
             If nHold < nHValue Then Exit Do
          Loop
          arr(nHold) = tmp
       Next i
    Loop Until nHValue = LBound(arr)
    ' answer
    SortNumbers = arr
End Function

Function SortVariants(vArray As Variant, Optional iColumn)
    ' This function sorts an array of Variants using the
    ' Quick Sort Methode. The sorting algorithme is held in
    ' the sub SortVariants_.
    ' iColumn:  (Optional) [Long] If the array has two dimensions,
    '           iColumn specifies which column (2nd dimension)
    '           will be sorted.
    Dim iCol As Long
    Dim arr  As Variant
    ' check dimension
    If IsMissing(iColumn) Or Not IsNumeric(iColumn) Then _
    iCol = -1 Else iCol = CLng(iColumn)
    ' sort by calling the sub procedure
    arr = vArray
    Call SortVariants_(arr, 0, UBound(arr), iCol)
    SortVariants = arr
End Function

Function ListVariants(vArray As Variant, Optional iColumn) As Variant
    ' This function creates a list of all values contained in an array.
    ' The function uses the Quick Sort Methode (sub SortVariants_).
    ' iColumn:  (Optional) [Long] If the array has two dimensions,
    '           iColumn specifies which column (2nd dimension)
    '           will be returned.
    Dim tmp     As Variant
    Dim arr()   As Variant
    Dim vLast   As Variant
    Dim cou     As Integer
    Dim i       As Integer
    Dim EOR     As Integer
    Dim iCol    As Long
    ' check dimension
    If IsMissing(iColumn) Or Not IsNumeric(iColumn) Then _
    iCol = -1 Else iCol = CLng(iColumn)
    ' sort array
    tmp = vArray
    Call SortVariants_(tmp, 0, UBound(tmp), iCol)
    ' create list of values
    vLast = vbNullChar & vbTab
    EOR = UBound(tmp)
    ReDim arr(-1 To -1)
    For i = 1 To EOR
' One dimension
If iCol = -1 Then
        If vLast <> tmp(i) Then
            vLast = tmp(i)
            If cou = 0 Then
                ReDim arr(0 To 0)
            Else
                ReDim Preserve arr(0 To cou)
            End If
            arr(cou) = tmp(i)
            cou = cou + 1
        End If
' Two dimensions
Else
        If vLast <> tmp(i, iCol) Then
            vLast = tmp(i, iCol)
            If cou = 0 Then
                ReDim arr(0 To 0)
            Else
                ReDim Preserve arr(0 To cou)
            End If
            arr(cou) = tmp(i, iCol)
            cou = cou + 1
        End If
End If
    Next i
    ListVariants = arr
End Function

Function RandomNumbers(iUBound As Long, _
            Optional Min, _
            Optional Max, _
            Optional AsString As Boolean) As Variant
    ' This function creates a vector of randomly generated Long Integers.
    ' iUBound:  [Long] Determines the size (UBound) of the returned array.
    ' Min:      (Optional) [Long] Determines the lower bound of the value range.
    '           If omitted, Min takes the value 0.
    ' Max:      (Optional) [Long] Determines the upper bound of the value range.
    '           If omitted, Min takes the value of iUBound.
    ' AsString: [Boolean] If True, the values will be returned as Strings.
    Dim lon() As Long
    Dim str() As String
    Dim i     As Long
    Dim iMin  As Long
    Dim iMax  As Long
    ' check Ubound
    If iUBound < 0 Then
        ReDim arr(-1 To -1)
        GoTo FCT_ANSWER
    End If
    ' get Min and Max
    If IsMissing(Min) Or Not IsNumeric(Min) Then _
    iMin = 0 Else iMin = CLng(Min)
    If IsMissing(Max) Or Not IsNumeric(Max) Then _
    iMax = iUBound Else iMax = CLng(Max)
    ' redim / randomize
    Call VBA.Randomize
    If AsString Then
        ReDim str(0 To iUBound)
    Else
        ReDim lon(0 To iUBound)
    End If
    ' fill array
    For i = 0 To iUBound
        If AsString Then
            str(i) = Int((iMax - iMin + 1) * Rnd(1) + iMin)
        Else
            lon(i) = Int((iMax - iMin + 1) * Rnd(1) + iMin)
        End If
    Next i
FCT_ANSWER:
    If AsString Then
        RandomNumbers = str
    Else
        RandomNumbers = lon
    End If
End Function

Function IsArray_(Array_) As Boolean
    ' This function is more reliable alternative to
    ' the VBA.IsArray function.
    Dim i As Long
    Err.Clear
    On Error Resume Next
    i = UBound(Array_)
    IsArray_ = (Err.Number = 0)
    On Error GoTo 0
End Function

Function Transpose(vArray As Variant) As Variant
    ' This function transposes a one/two-dimensional array.
    ' Comparable to Excel.WorksheetFunction.Transpose().
    Dim arr() As Variant
    Dim bTwo  As Boolean
    Dim bCut  As Boolean
    Dim x     As Long
    Dim y     As Long
    Dim i     As Long
    Dim j     As Long
    ' check if vArray has two dimensions
    On Error Resume Next
    y = UBound(vArray, 2)
    bTwo = (Err.Number = 0)
    On Error GoTo 0
    ' check if the first dimension in needed
    If bTwo Then
        bCut = LBound(vArray, 1) = UBound(vArray, 1)
    End If
    ' set bounds
    x = UBound(vArray, 1)
    If bTwo Then
        y = UBound(vArray, 2)
    Else
        y = LBound(vArray)
    End If
    ' transpose from one dimension
    If Not bTwo Then
        ReDim arr(y To y, LBound(vArray, 1) To x)
        For i = LBound(vArray, 1) To x
            arr(y, i) = vArray(i)
        Next i
    ' transpose from two dimensions into one
    ElseIf bCut Then
        ReDim arr(LBound(vArray, 2) To y)
        For j = LBound(vArray, 2) To y
            arr(j) = vArray(LBound(vArray, 1), j)
        Next j
    ' transpose from two dimensions into two
    Else
        ReDim arr(LBound(vArray, 2) To y, LBound(vArray, 1) To x)
        For i = LBound(vArray, 1) To x
        For j = LBound(vArray, 2) To y
            arr(j, i) = vArray(i, j)
        Next j
        Next i
    End If
    Transpose = arr
End Function

Function FindInArray(value, _
            vArray As Variant, _
            Optional iColumn, _
            Optional iStart) As Long
    ' This function returns the index of an item in a one/two-dimensional array.
    ' The function returns -1 if the item was not found
    ' value:    [Variant] Lookup value.
    ' iColumn:  (Optional) [Long] If the array has two dimensions,
    '           iColumn specifies which column (2nd dimension)
    '           will be searched.
    ' iStart:   (Optional) [Long] Determines where the search will be started.
    FindInArray = -1
    Dim i    As Long
    Dim iCol As Long
    Dim iSta As Long
    Dim iTwo As Long
    ' check if vArray has two dimensions
    On Error Resume Next
    i = UBound(vArray, 2)
    iTwo = IIf(Err.Number = 0, 1, -1)
    On Error GoTo 0
    ' check variables
    If IsMissing(iColumn) Or Not IsNumeric(iColumn) Then _
    iCol = iTwo Else iCol = CLng(iColumn)
    If IsMissing(iStart) Or Not IsNumeric(iStart) Then _
    iSta = LBound(vArray, 1) Else iSta = CLng(iStart)
    If iSta < LBound(vArray, 1) Then GoTo CLEAN_EXIT
    ' One dimension
    If iTwo = -1 Then
        For i = 1 To UBound(vArray)
            If vArray(i) = value Then
                FindInArray = i
                Exit For
            End If
        Next i
    ' Two Dimensions
    Else
        For i = iSta To UBound(vArray, 1)
            If vArray(i, iCol) = value Then
                FindInArray = i
                Exit For
            End If
        Next i
    End If
CLEAN_EXIT:
End Function

'**************************************
'**  SUB-PROCS (FUNCTIONS ENGINES)   **
'**************************************
Private Sub SortVariants_(vArray As Variant, inLow As Long, inHi As Long, iCol As Long)
    ' Quick Sort Methode.
    ' For more infos and comments on the methode, refer to:
    ' http://vbnet.mvps.org/index.html?code/sort/qsvariations.htm
    
    'vArray()   The array to sort
    'inLow      Lower bound of sort point
    'inHi       Upper bound of sort point
    'iCol       Column that will be sorted, -1 means only one dimension (Ph. Heiz, 29.12.2004)
    Dim pivot   As Variant
    Dim tmpSwap As Variant
    Dim tmpLow  As Long
    Dim tmpHi   As Long
    tmpLow = inLow
    tmpHi = inHi
' One dimension
If iCol = -1 Then
    pivot = vArray((inLow + inHi) \ 2)
    While (tmpLow <= tmpHi)
        While (vArray(tmpLow) < pivot And tmpLow < inHi)
           tmpLow = tmpLow + 1
        Wend
        While (pivot < vArray(tmpHi) And tmpHi > inLow)
           tmpHi = tmpHi - 1
        Wend
        If (tmpLow <= tmpHi) Then
             tmpSwap = vArray(tmpLow)
             vArray(tmpLow) = vArray(tmpHi)
             vArray(tmpHi) = tmpSwap
             tmpLow = tmpLow + 1
             tmpHi = tmpHi - 1
        End If
    Wend
' Two Dimensions (Ph. Heiz, 29.12.2004)
Else
    pivot = vArray((inLow + inHi) \ 2, iCol)
    While (tmpLow <= tmpHi)
        While (vArray(tmpLow, iCol) < pivot And tmpLow < inHi)
           tmpLow = tmpLow + 1
        Wend
        While (pivot < vArray(tmpHi, iCol) And tmpHi > inLow)
           tmpHi = tmpHi - 1
        Wend
        If (tmpLow <= tmpHi) Then
             tmpSwap = vArray(tmpLow, iCol)
             vArray(tmpLow, iCol) = vArray(tmpHi, iCol)
             vArray(tmpHi, iCol) = tmpSwap
             tmpLow = tmpLow + 1
             tmpHi = tmpHi - 1
        End If
    Wend
End If
' recursive call
    If (inLow < tmpHi) Then SortVariants_ vArray, inLow, tmpHi, iCol
    If (tmpLow < inHi) Then SortVariants_ vArray, tmpLow, inHi, iCol
End Sub

Conclusion :


SortNumbers: permet de trier (tri croissant) un vecteur de Long Integers.

SortVariants: permet de trier (croissant aussi) un tableau de variant. S'il s'agit d'un tableau bidimensionnel, le choix de la colonne est permis.

ListVariants: crée une liste triée de valeurs contenues dans une colonne d'un tableau (uni- ou bidimensionnel). P.ex.: 2,3,4,1,3,2,4,1,2,3 -> 1,2,3,4.

RandomNumbers: crée un vecteur dont les éléments sont des Long Integer aléatoires. Il est possible de déterminer la taille (UBound) du vecteur, la fourchette dans laquelle les valeurs aléatoires seront générées, et si les valeurs sont retournées comme String (à défaut de Long).
J'ai intégré cette dernière option pour la raison suivante: lors d'un tri, les valeurs String 1,2,10 sont triées 1,10,2; ces mêmes valeurs sont triées 1,2,10 lorsqu'elles sont passées comme Long.

IsArray_: même chose que IsArray de la librairies VBA, mais en moins débile.

Transpose: à comparer avec Excel.WorksheetFunction.Transpose().

FindInArray: trouve un élément dans un tableau et retourne son indice de position.

SortVariants_: fonction privée et subordonnée aux fonctions SortVariants et ListVariants.

Je vous renvoie à l'adresse suivante pour ce qui est du tri matricel:
http://vbnet.mvps.org/index.html?code/sort/qsvariations.htm

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (philheiz)