Transfert de données de Variable Tableau Vers Variable Tableau (Mémoire Machine)

[laurent950]

Bonjour le Forum,

Je cherche a transférer des données de valeurs stocké dans une variable tableau (Données saisie et récupérer) dans un autres Tableau source qui est déjà dimensionné. (Exemple très simple joint au message dans le fichier excel ci-joint )

Tous cela directement de (De Variable Tableaux à Variable Tableaux en une seul fois) sans passer par une boucle.

Je pensais que Resize fonctionner mais il y a une erreur '424' Est l'autres méthode fonctionne mais pas comme je le voudrais.

Je connais la méthode traditionnelle en passant par une boucle mais ici ce n'est pas le but chercher.

Si vous avez la solution cela serait Extra.

Au plaisir de vous lire et vous répondre

Code :

Sub test()

Dim TabAremplir() As Variant
ReDim TabAremplir(1 To 17, 1 To 5)

Dim TabBbaseSaisie() As Variant

' Donnée a recupérer du tableau saisie
TabBbaseSaisie = Range(Cells(10, 12), Cells(14, 14))

' Erreur d"execuction '424' / Objet requis
'TabAremplir(8, 4).Resize(TabBbaseSaisie(1, 1), TabBbaseSaisie(5, 3)) = TabBbaseSaisie

' Dans la feuille ca fonctionne : 
'Cells(8, 4).Resize(UBound(TabBbaseSaisie, 1), UBound(TabBbaseSaisie, 2)) = TabBbaseSaisie

'ps : Je voudrais la même choses de Variable Tableau Vers Variable Tableau

' Cf Image 1
' Les données sont transferé en une seul fois mais pas dans les bonne case !!
TabAremplir(8, 4) = TabBbaseSaisie

End Sub

Laurent

 

[job75]

Re : Transfert de données de Variable Tableau Vers Variable Tableau (Mémoire Machine)

Bonjour laurent950,

Deux remarques :

- on ne peut pas faire n'importe quoi sur des tableaux VBA

- leur modification par des boucles est très rapide.

A+

 

[laurent950]

Re : Transfert de données de Variable Tableau Vers Variable Tableau (Mémoire Machine)

Bonjour Job75,

Je suis en faite arrivée à faire des unions de tableaux à l'aide d'une variable "Range"

Je vais bien arrivée à trouver une solution mais je trouve cela déjà pas mal.

Sub test()

Dim Donner As Worksheet
Set Donner = Worksheets("Donner")

' Créer un variable range
Dim Temp As Range
Set Temp = Donner.Range(Donner.Cells(8, 3), Donner.Cells(12, 7))

' Donnée a recupérer des tableaux saisies
Dim Tab1() As Variant
Tab1 = Donner.Range(Donner.Cells(10, 12), Donner.Cells(14, 14))
Dim Tab2() As Variant
Tab2 = Donner.Range(Donner.Cells(20, 11), Donner.Cells(24, 11))
Dim Tab3() As Variant
Tab3 = Donner.Range(Donner.Cells(7, 18), Donner.Cells(11, 18))

' Remplir la variable Range avec les différente Positions pour les assemblages
Temp(1, 2).Resize(UBound(Tab1, 1), UBound(Tab1, 2)) = Tab1
Temp(1, 1).Resize(UBound(Tab2, 1), UBound(Tab2, 2)) = Tab2
Temp(1, 5).Resize(UBound(Tab3, 1), UBound(Tab3, 2)) = Tab3

' Créer un tableau un tableau
Dim TabAremplir() As Variant
TabAremplir = Temp

' Decharge la variable "Range" Temp (Libére la mémoire)
Set Temp = Nothing

' Coller se Tableaux (Crée d'union de plusieurs tableaux) dans la FeuilVide
' Dans la feuille Vide le tableau sera recopier en une fois
' Coller les valeurs de ce tableau reconstituer a partir de plusieur
' tableau (Variable tableau) comme ci-cela était des Unions
' en une seule fois
Dim FeuilVide As Worksheet
Set FeuilVide = Worksheets("FeuilVide")

FeuilVide.Cells(8, 3).Resize(UBound(TabAremplir, 1), UBound(TabAremplir, 2)) = TabAremplir
End Sub

Nota : @Staple1600 (Solution pour trouver la dernière cellule non vide d'une colonne d'une ligne)

Sub Questions_A_Laurent()
' Merci @Staple1600
Dim Umma As Range, Gumma As Range
Randomize 1600
Columns(2).Clear
Cells(Int((Rnd * 17) + 1), 2) = "Staple"
Set Umma = Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
Set Gumma = Cells(Rows.Count, 2).End(3)(2)
zX = Umma.Address(0, 0): zY = Gumma.Address(0, 0)
MsgBox Umma.Address = Gumma.Address, vbInformation, zX & "<|>" & zY
MsgBox Umma.Resize(, 2).Address
With Application
Umma.Resize(, 2) = Array(.UserName, .UsableWidth)
End With
End Sub

Laurent

 

[laurent950]

Solution :
* Variable Tableau 1 Dimension
* Contenance = 1 Variable Tableau (Qui contient uniquement les valeurs)
* Contenance = 1 Variable Objet (Qui contient le Range)
* Conclusion Variable Tableau double entrées.

Sub test()
Dim FD As Worksheet
    Set FD = Worksheets(ActiveSheet.Name)
Dim TbBis(1 To 2) As Variant
        TbBis(1) = FD.Range("A10:B" & FD.Range("B1048576").End(xlUp).Row).Value
    Set TbBis(2) = FD.Range("A10:B" & FD.Range("B1048576").End(xlUp).Row)
' Suppression de la surbrillance
        TbBis(2).Interior.Pattern = xlNone
    For i = LBound(TbBis(1), 1) To UBound(TbBis(1), 1)
        If Len(TbBis(1)(i, 1)) <> 14 Then
            TbBis(2)(i, 1).Interior.Color = 65535
        End If
        If Len(TbBis(1)(i, 2)) <> 15 Then
            TbBis(2)(i, 2).Interior.Color = 65535
        End If
    Next i
' EXEMPLE POUR RESTITUTION DU TABLEAU DE VALEURS DANS LA FEUILLE
    FD.[D10].Resize(UBound(TbBis(1), 1), UBound(TbBis(1), 2)) = TbBis(1)
' Libére la mémoire
    Erase TbBis
    Set FD = Nothing
    Calc1 = Empty: Calc2 = Empty
End Sub

 

[laurent950]

Solution donner par @Dranred

Avec des tableaux structuré, mais cela fonctionne aussi avec des Ranges.
Valeurs dans les plages discontinu avec union :
- Solution pour transfert dans une variable tableau :

Code ci-dessous :

Private Sub Cbx_DropButtonClick()
   Dim Target As Range
   Dim Zone As Range
   Dim TCible() As Variant
   Dim TSource() As Variant
   Dim j As Long: j = 0
   Set Target = Union([Tableau1[Nom]], [Tableau2[Nom]], [Tableau3[Nom]], [Tableau4[Nom]])
   ReDim TCible(1 To Target.Count, 1 To 1)
   For Each Zone In Target.Areas
      TSource = Zone.Value
      For LS = 1 To UBound(TSource, 1)
         LC = LC + 1: TCible(LC, 1) = TSource(LS, 1)
         Next LS, Zone
    Cbx.List = TCible
End Sub

**************************************************************************************************************
Avec Fonction Evaluate : Option Bis
' http://boisgontierjacques.free.fr/pages_site/tableaux.htm

Private Sub Cbx_DropButtonClick()
   Dim Target As Range
   Dim TCible() As Variant
   Dim i, j As Long
   Set Target = Union([Tableau1[Nom]], [Tableau2[Nom]], [Tableau3[Nom]], [Tableau4[Nom]])
   ReDim TCible(1 To 1)
   For i = 1 To Target.Areas.Count
        For j = 1 To Target.Areas.Item(i).Count
            TCible(UBound(TCible)) = Application.Index(Target.Areas.Item(i), Evaluate("Row(" & j & ":" & j & ")"))
            ReDim Preserve TCible(1 To UBound(TCible) + 1)
        Next j
        If i = Target.Areas.Count Then ReDim Preserve TCible(1 To UBound(TCible) - 1)
   Next i
   Cbx.List = TCible
End Sub