Comment Transférer 1 dimension d’une Variable Tableau Multidimensionnel vers Excel

[laurent950]

Bonsoir,

' Fichier avec exemple ici (Comment extraire sans une boucle explication ci-dessous de ceux que j'ai fais)

J’aimerais connaitre la ligne de commande qui permet d’extraire en une fois une dimension d’une Variable Tableau Multidimensionnel.

J’ai construit sur la Base des numéro du Keno (des couples de Numéro que j’ai stocké comme suit
Variable tableau de 4 dimensions ici pour cet exemple

- Remplissage de la dimension 1 = couple de 2 numéros
- Remplissage de la dimension 2 = couple de 3 numéros
- Remplissage de la dimension 3 = couple de 4 numéros
- Remplissage de la dimension 4 = couple de 5 numéros

Mais comment extraire juste la dimension que l’on veut sans passer par une boucle.
C’est le remplissage est ultra rapide et l’extraction serait hyper rapide sans refaire une nouveau tour de boucle.

J’ai argumenté la macro qui peux servir d’exemple avec une astuces pour crée une colonne vides entre chaque colonne dans cette variable tableau multidimensionnel

Code :

Sub KenoCoupleT3D()
' Base Keno

' Feuilles sources ou sont stocké les valeur (Feuille Excel)
 Dim F1 As Worksheet
 Set F1 = Worksheets("Keno")
 
 ' Feuilles du Resultat extrait du tableau multidimensionnel
 Dim F2 As Worksheet
 Set F2 = Worksheets("Couple2")
 Dim F3 As Worksheet
 Set F3 = Worksheets("Couple3")
 Dim F4 As Worksheet
 Set F4 = Worksheets("Couple4")
 Dim F5 As Worksheet
 Set F5 = Worksheets("Couple5")
 
 ' Donner de la Feuilles sources Stocké dans le Tableau T()
 Dim T As Variant
 fin = F1.Range("A65536").End(xlUp).Row
 T = F1.Range(F1.Cells(2, 1), F1.Cells(fin, 7)) ' Valeur source stocké dans un tableau
 
 ' Création d'un tableau dimensionnel.
 Dim Tpos() As Variant
 ' Tpos(Nombres de Lignes,Nombres de Colonnes, Nombres de dimensions)
 ' Ici même nombre de lignes que le tableau T(), 12 colonnes, et 4 dimensions)
 ReDim Tpos(1 To UBound(T, 1), 1 To 22, 1 To 4) ' Ici dimension d'un tableau multidimensionnel

' Boucle de Remplissage du tableau dimensionnel
' Remplissage date et Remplissage des heures
' Pour dimension (1 et 2 et 3 et 4)
 For i = 1 To UBound(T, 1)
    For j = 1 To 2
        For k = 1 To UBound(Tpos, 1)
                For m = 1 To UBound(Tpos, 3)
                    Tpos(k, j, m) = T(i, j)
                Next m
        Next k
    Next j
 Next i
 
 ' Ici pour exemples de remplissages
 ' dimension 1 = Combinaison de couples de 2 numéros
 ' dimension 2 = Combinaison de couples de 3 numéros
 ' dimension 3 = Combinaison de couples de 4 numéros
 ' dimension 4 = Combinaison de couples de 5 numéros
 cpt = 3
 For i = 1 To UBound(Tpos, 3)
    For j = 1 To UBound(T, 1)
        For k = 3 To UBound(T, 2)
            For l = k + i To UBound(T, 2)
                    ' Voir fonction A2_FunKeno cf explication dans la fonction
                    couple2 T, Tpos, j, cpt, i, k, l
                    Debug.Print Tpos(j, cpt, i)
                    ' Ici un compteur pour une colonne vide entre chaque couple.
                    cpt = cpt + 2
                Next l
        Next k
        cpt = 3
    Next j
    cpt = 3
 Next i
 
' Ici j'aimerais extraire les dimensions ( 1 puis 2 puis 3 puis 4) comme ont le fait avec une
' Ligne de commande pour un tableau 2 dimensions :
' Qui serait = F2.Cells(2, 1).Resize(UBound(Tpos, 1), UBound(Tpos, 2)) = Tpos

' Mais qui ne fonctionne pas comme ceci pour un tableau Multidimensonel.
' Transfert vers excel en une seul fois pour la : Dimension 1
'F2.Cells(2, 1).Resize(UBound(Tpos, 1), UBound(Tpos, 2), 1) = Tpos
' Transfert vers excel en une seul fois pour la : Dimension 2
'F3.Cells(2, 1).Resize(UBound(Tpos, 1), UBound(Tpos, 2), 2) = Tpos
' Transfert vers excel en une seul fois pour la : Dimension 3
'F4.Cells(2, 1).Resize(UBound(Tpos, 1), UBound(Tpos, 2), 3) = Tpos
' Transfert vers excel en une seul fois pour la : Dimension 4
'F5.Cells(2, 1).Resize(UBound(Tpos, 1), UBound(Tpos, 2), 4) = Tpos

' Je suis Obliger de passer par une boucle pour extraire les valeur vers Excel
' Ici une boucle

' Dimension (Extraction de toutes les dimensions avec fonction)
 For i = 1 To UBound(Tpos, 3)
    For j = 1 To UBound(Tpos, 1)
       For k = 1 To UBound(Tpos, 2)
        ' Voir fonction A3_Extraction cf explication dans la fonction
           Transfert Tpos, j, k, i, F2, F3, F4, F5
       Next k
    Next j
 Next i
End Sub

Fonction Lier au code :
Fonction de remplissage de la variable tableau 4 dimensions // A2_FunKeno

Function couple2(T, Tpos, j, cpt, i, k, l)
     If i = 1 Then
        ' Ici remplissage de la dimension 1 = couple de 2 numéros
        Tpos(j, cpt, i) = "'" & T(j, k) & "-" & T(j, l)
    ElseIf i = 2 Then
        ' Ici remplissage de la dimension 2 = couple de 3 numéros
        Tpos(j, cpt, i) = "'" & T(j, k) & "-" & T(j, k + 1) & "-" & T(j, l)
    ElseIf i = 3 Then
        ' Ici remplissage de la dimension 3 = couple de 4 numéros
        Tpos(j, cpt, i) = "'" & T(j, k) & "-" & T(j, k + 1) & "-" & T(j, k + 2) & "-" & T(j, l)
    ElseIf i = 4 Then
        ' Ici remplissage de la dimension 4 = couple de 5 numéros
        Tpos(j, cpt, i) = "'" & T(j, k) & "-" & T(j, k + 1) & "-" & T(j, k + 2) & "-" & T(j, k + 3) & "-" & T(j, l)
    End If
 End Function

Fonction d'extration des dimensions // A3_Extraction

Function Transfert(Tpos, j, k, i, F2, F3, F4, F5)
' Transfère les éléments du tableau vers Excel pour chaques dimensions
    If i = 1 Then
        ' Ici extraction de la dimension 1 vers la feuille Couple2 d'Excel
        F2.Cells(j, k) = Tpos(j, k, i)
    ElseIf i = 2 Then
        ' Ici extraction de la dimension 2 vers la feuille Couple3 d'Excel
        F3.Cells(j, k) = Tpos(j, k, i)
    ElseIf i = 3 Then
         ' Ici extraction de la dimension 3 vers la feuille Couple4 d'Excel
        F4.Cells(j, k) = Tpos(j, k, i)
    ElseIf i = 4 Then
         ' Ici extraction de la dimension 4 vers la feuille Couple5 d'Excel
        F5.Cells(j, k) = Tpos(j, k, i)
    End If
End Function

Laurent

 

[BOISGONTIER]

Re : Comment Transférer 1 dimension d’une Variable Tableau Multidimensionnel vers Exc

Bonsoir,

Transfert d'un colonne ou d'une ligne d'un tableau 2D dans un champ

JB

 

[laurent950]

Re : Comment Transférer 1 dimension d’une Variable Tableau Multidimensionnel vers Exc

Bonsoir,

En Faite c'est une dimensions entiére d'une variable tableau multidimensionnel dans cet exemple : Variable tableau 4 dimensions

comment extraire en 1 seule fois (1 seule dimension entière) de cet Variable Tableau Multidimensionnel qui en contient 4 dimensions ?

Je sais pas faire.
J'ai essayer par exemple ceux-ci pour extraire Uniquement toue la dimension 2 (en une seul fois).
Ca ne fonctionne pas ?

' Transfert vers excel en une seul fois pour la : Dimension 2
' F3.Cells(2, 1).Resize(UBound(Tpos, 1), UBound(Tpos, 2), 2) = Tpos

laurent

 

[laurent950]

Re : Comment Transférer 1 dimension d’une Variable Tableau Multidimensionnel vers Exc

Bonsoir

j'ai fait une Mise a jour du poste #1 et du Poste #3, concernant l'explication avec le code coller et argumenté.

En remerciant par avance celui qui partagera cette solution avec moi j'ai pas trouver encore malgré mais recherche.

Laurent

 

[Efgé]

Re : Comment Transférer 1 dimension d’une Variable Tableau Multidimensionnel vers Exc

Bonjour laurent950, Bonjour Boisgontier,
Une proposition qui sera, à n'en pas douter revue et améliorée.

Il y a une méprise dans le code d'origine.

Les tableau à trois dimentions se décomposent ainsi :
T(Nombre de tableaux, nombre de lignes par tableau, nombre de colonnes par tableau)

Un exemple :

Sub test()
Dim i&, j&, k&
Dim TMulti As Variant, TSimple As Variant
'4 tablaux de 23 lignes, 12 colonnes
ReDim TMulti(1 To 4, 1 To 23, 1 To 12)
'On rempli le Multi
'Pour chaque tableau
For i = LBound(TMulti, 1) To UBound(TMulti, 1)
    'Pour chaque ligne
    For j = LBound(TMulti, 2) To UBound(TMulti, 2)
    'Pour chaque colonne
        For k = LBound(TMulti, 3) To UBound(TMulti, 3)
            TMulti(i, j, k) = i & "_" & j & "_" & k
        Next k
    Next j
Next i
'on dimentionne le tableau d'arrivée
ReDim TSimple(1 To UBound(TMulti, 2), 1 To UBound(TMulti, 3))
'On extrait le troisième tableau dans le tableau d'arrivée
    For i = LBound(TMulti, 2) To UBound(TMulti, 2)
        For j = LBound(TMulti, 3) To UBound(TMulti, 3)
            TSimple(i, j) = TMulti(3, i, j) '3 pour le troisième tableau
        Next j
    Next i
' on colle le résultat
Sheets("Feuil1").Cells(1, 1).Resize(UBound(TSimple, 1), UBound(TSimple, 2)) = TSimple
End Sub

Cordialement

 

[laurent950]

Pour moi
Tri d’un tableau (Array) à 1 dimension
Le coeur du programme est simple pour le reste c'est le principe du tri quickSort

Sub MiseEnForme()
Dim t() As Variant, i As Integer, j As Integer
ReDim t(1)
For i = 7 To ActiveSheet.Cells(ActiveSheet.Cells(65535, 3).End(xlUp).Row, 3).Row
    t(i - 6) = Range(Cells(i, 3), Cells(i, 7))
    tri t, i - 6, LBound(t(1), 2), UBound(t(1), 2)
    ReDim Preserve t(UBound(t) + 1)
Next i
' Restitution de se tableau multidimension
ReDim Preserve t(UBound(t) - 1)
For i = LBound(t, 1) To UBound(t, 1)
Cells(i + 6, 9).Resize(UBound(t(i), 1), UBound(t(i), 2)) = t(i)
Next i
End Sub

La fonction de tri

Sub tri(a() As Variant, i, gauc, droi) ' Quick sort
   ref = a(i)(1, (gauc + droi) \ 2)
   g = gauc: d = droi
   Do
     ' Pour un tri Croissant
      Do While a(i)(1, g) < ref: g = g + 1: Loop
      Do While ref < a(i)(1, d): d = d - 1: Loop
        If g <= d Then
           temp = a(i)(1, g): a(i)(1, g) = a(i)(1, d): a(i)(1, d) = temp
           g = g + 1: d = d - 1
        End If
    Loop While g <= d
    If g < droi Then Call tri(a, i, g, droi)
    If gauc < d Then Call tri(a, i, gauc, d)
End Sub

'Pour un tri décroissant
'Do While a(i)(g, colTri) > ref: g = g + 1: Loop
'Do While ref > a(i)(d, colTri): d = d - 1: Loop

 

[laurent950]

Pour moi,
Transpose Tableau en colonne vers Tableau en ligne

Sub Transpose()
Dim t() As Variant, i, j As Integer
Dim Feuil1, Feuil2 As Worksheet
Set Feuil1 = Worksheets("Feuil1")
Set Feuil2 = Worksheets("remplissage tableau")
ReDim t(1 To 4, 1 To 1)
For i = 2 To Feuil1.Cells(1, 256).End(xlToLeft).Column ' Dernière colonnes non vide
    For j = 1 To Feuil1.Cells(65536, 1).End(xlUp).Row  ' Dernière lignes non vide
        If j = 4 Then t(j, i - 1) = Format(Cells(j, i), "hh:mm:ss") Else t(j, i - 1) = Cells(j, i)
    Next j
    Debug.Print UBound(t, 2)
    ReDim Preserve t(1 To 4, 1 To UBound(t, 2) + 1)
Next i
' Restitution du tableau
ReDim Preserve t(1 To 4, 1 To UBound(t, 2) - 1)
For i = LBound(t, 2) To UBound(t, 2)
Feuil2.Cells(i + 2, 2).Resize(1, UBound(t, 1)) = Application.Transpose(Application.Index(t, , i))
Next i
End Sub