XL 2019 Redimensionnement dynamique d'une matrice

[amgue]

Bonjour à tous,

Pour redimensionner dynamiquement les lignes d'une matrice dans mon code VBA, j'utilise l'instruction suivante :

If (ptr + 10) >= UBound(aOut, 1) Then 
    ReDim Preserve aOut(1 To UBound(aOut, 1) + GROWTH_FACTOR, 1 To UBound(aOut, 2)) 
End If

Ou GROWTH_FACTOR est une constante définie à 100, et la variable ptr, après plusieurs passages, se situe entre 92 et 98, dans ce cas.

Cependant, cette ligne :

ReDim Preserve aOut(1 To UBound(aOut, 1) + GROWTH_FACTOR, 1 To UBound(aOut, 2))

déclenche systématiquement l'erreur "L'indice n'appartient pas à la sélection".

Voici comment la matrice aOut est initialisée :

' Initialisation de aOut avec 100 lignes et autant de colonnes que LO_DistribGains 
ReDim aOut(1 To GROWTH_FACTOR, 1 To LO_DistribGains.ListColumns.Count) 
ptr = 0 
Debug.Print "aOut initialisé avec " & UBound(aOut, 2) & " colonnes" ' 21 Colonnes

Comment résoudre ce problème ?

Merci d’avance ! 😊

 

[vgendron]

bonjour

on ne peut redimensionner QUE la seconde dimension du tableau

 

[fanch55]

Bonjour,

Le mot clé Preserve permet uniquement de modifier la limite supérieure de la dernière dimension du tableau.

Cf aide de microsoft sur l'instruction Redim :

ReDim Preserve aOut(1 To UBound(aOut, 1) + GROWTH_FACTOR, 1 To UBound(aOut, 2))

 

[job75]

Bonsoir,

Le mot clé Preserve permet uniquement de modifier la limite supérieure de la dernière dimension du tableau.

Et c'est pour cela qu'on est souvent obligé de transposer la matrice.

A+

 

[amgue]

Bonsoir vgendron, fanch55, job75, le forum,

Donc :

If (ptr + 10) >= UBound(aOut, 1) Then 
    ReDim Preserve aOut(1 To UBound(aOut, 1) + GROWTH_FACTOR, 1 To UBound(aOut, 2)) 
End If

devient :

If (ptr + 10) >= UBound(aOut, 2) Then 
    ReDim Preserve aOut(1 To UBound(aOut, 1), 1 To UBound(aOut, 2) + GROWTH_FACTOR) 
End If

Il faut refaire toutes ces lignes :

aOut(ptr, COL_ID) = " Global"               
aOut(ptr, COL_CAT) = Cat

en ceci :

aOut(COL_ID, ptr) = " Global"
aOut(COL_CAT, ptr) = Cat

et enfin utiliser Transpose !

 

[jurassic pork]

Hello,
voici ce que propose Ryan Wells :

Sub ReDimPreserve2D_AnyDimension()
Dim MyArray() As Variant
ReDim MyArray(1, 3)
'put your code to populate your array here
For i = LBound(MyArray, 1) To UBound(MyArray, 1)
    For j = LBound(MyArray, 2) To UBound(MyArray, 2)
        MyArray(i, j) = i & "," & j
    Next j
Next i
MyArray = ReDimPreserve(MyArray, 2, 4)
End Sub


Private Function ReDimPreserve(MyArray As Variant, nNewFirstUBound As Long, nNewLastUBound As Long) As Variant
    Dim i, j As Long
    Dim nOldFirstUBound, nOldLastUBound, nOldFirstLBound, nOldLastLBound As Long
    Dim TempArray() As Variant 'Change this to "String" or any other data type if want it to work for arrays other than Variants. MsgBox UCase(TypeName(MyArray))
'---------------------------------------------------------------
'COMMENT THIS BLOCK OUT IF YOU CHANGE THE DATA TYPE OF TempArray
    If InStr(1, UCase(TypeName(MyArray)), "VARIANT") = 0 Then
        MsgBox "This function only works if your array is a Variant Data Type." & vbNewLine & _
               "You have two choice:" & vbNewLine & _
               " 1) Change your array to a Variant and try again." & vbNewLine & _
               " 2) Change the DataType of TempArray to match your array and comment the top block out of the function ReDimPreserve" _
                , vbCritical, "Invalid Array Data Type"
        End
    End If
'---------------------------------------------------------------
    ReDimPreserve = False
    'check if its in array first
    If Not IsArray(MyArray) Then MsgBox "You didn't pass the function an array.", vbCritical, "No Array Detected": End
    
    'get old lBound/uBound
    nOldFirstUBound = UBound(MyArray, 1): nOldLastUBound = UBound(MyArray, 2)
    nOldFirstLBound = LBound(MyArray, 1): nOldLastLBound = LBound(MyArray, 2)
    'create new array
    ReDim TempArray(nOldFirstLBound To nNewFirstUBound, nOldLastLBound To nNewLastUBound)
    'loop through first
    For i = LBound(MyArray, 1) To nNewFirstUBound
        For j = LBound(MyArray, 2) To nNewLastUBound
            'if its in range, then append to new array the same way
            If nOldFirstUBound >= i And nOldLastUBound >= j Then
                TempArray(i, j) = MyArray(i, j)
            End If
        Next
    Next
    'return the array redimmed
    If IsArray(TempArray) Then ReDimPreserve = TempArray
End Function

J'ai testé ce code comme ceci:

Sub TestRedimPreserve()
Dim arr(1 To 10, 1 To 5)
Dim NewArr As Variant
NewArr = arr
NewArr(1, 1) = "début"
NewArr(10, 5) = "fin"
NewArr = ReDimPreserve(NewArr, 20, 10)
NewArr(20, 10) = "Nouvelle fin"
End Sub

Cela m'a l'air de fonctionner.

Ami calmant, J.P

 

[amgue]

Bonsoir jurassic pork,

Merci pour le code.

le test de dépassement de la taille de aOut, se fait dans trois sections du code de la même fonction.

En inversant les indices dans aOut pour redimensionner la deuxième dimensions, afin d'utiliser Transpose pour le transfert dans la feuille :

If (ptr + 10) >= UBound(aOut, 2) Then
                    newSize = UBound(aOut, 2) + GROWTH_FACTOR
                    If newSize > 0 Then
                        ReDim Preserve aOut(1 To UBound(aOut, 2), 1 To newSize)
                    Else
                        Debug.Print "Erreur : newSize n'est pas valide."
                        Exit Sub
                    End If
                End If

Mais, j'obtiens toujours la même erreur d'indice :

Ligne ptr d'entrée actuel : 90
Ligne ptr dans 2. Section Global : 90
!!! ERREUR dans MettreAJourAOut !!!
Description : L'indice n'appartient pas à la sélection.
Numéro : 9
Ligne ptr en cours : 90
Clé en cours :