Jointure 2 array

Version imprimable

Jointure 2 array

Bonjour,

Je souhaiterais joindre 2 array dont la clé est l'ID afin de récupérer le champ quantité dans l'Array1.
Par ailleurs je souhaiterais ajouter un champ "Prix * Quantité".
J'ai ajouté le résultat attendu.
Enfin, les deux array contiendront bcp de données.

Merci d'avance de votre aide

Array1
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 Dim MyArray1(2, 2) MyArray1(0, 0) = "ID" MyArray1(0, 1) = "Client" MyArray1(0, 2) = "Prix" MyArray1(1, 0) = "ID1" MyArray1(1, 1) = "Client A" MyArray1(1, 2) = 20 MyArray1(2, 0) = "ID2" MyArray1(2, 1) = "Client B" MyArray1(2, 2) = 30
ID Client Prix

ID1 Client A 20

ID2 Client B 30

Array2
Code:

1 2 3 4 5 6 7 8 9 Dim MyArray2(2, 1) MyArray2(0, 0) = "ID" MyArray2(0, 1) = "Quantité" MyArray2(1, 0) = "ID2" MyArray2(1, 1) = 5 MyArray2(2, 0) = "ID1" MyArray2(2, 1) = 2
ID Quantité

ID2 5

ID1 2

Résultat souhaité

ID Client Prix Quantité Prix * Quantité

ID1 Cleint A 20 2 40

ID2 Client B 30 5 150

10/10/2019, 15h30
MarcelG

Salut,

Jacques Boisgontier a développé une fonction quant à la fusion horizontale de 2 tableaux.

Via un moteur de recherche, tu y parviendras aisément.

Par ailleurs, une discussion à ce sujet est déjà parue sur ce Forum.

1 pièce(s) jointe(s)

Bonjour,
Un fichier téléchargé de ce super site je crois répond à tes besoins si non peut te donner un coup de main pour avancer
Je m'excuse de ne pas cité le nom du membre qui a développé ce code
BONNE CONTINUATION

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
'--- Déclaration des variables
Dim fProd As Worksheet, fMat As Worksheet, fPrix As Worksheet
Dim lProd As Long, lMat As Long, lPrix As Long
Dim dProd As Object, dMat As Object, dPrix As Object, dPrixU As Object
Dim tMat()
Private Sub UserForm_Initialize()
'--- On définit les variables
Set fProd = Feuil1: Set fMat = Feuil2: Set fPrix = Feuil3
lProd = fProd.[a65000].End(xlUp).Row: lMat = fMat.[a65000].End(xlUp).Row: lPrix = fPrix.[a65000].End(xlUp).Row:
Set dProd = CreateObject("Scripting.Dictionary"): Set dMat = CreateObject("Scripting.Dictionary")
Set dPrix = CreateObject("Scripting.Dictionary"): Set dPrixU = CreateObject("Scripting.Dictionary")
With fMat: tMat = fMat.Range(.Cells(2, 1), .Cells(lMat, 3)).Value: End With
'--- On charge les dictionary 1 et 3
For Each Cell In fProd.Range("a2:a" & lProd): dProd(Cell.Value) = Cell.Offset(, 1).Value: Next Cell
For Each Cell In fPrix.Range("a2:a" & lPrix): dPrix(Cell.Value) = Cell.Offset(, 2).Value: Next Cell
'--- On enregistre les valeurs de la combobox
Me.ComboBox1.List = dProd.Keys
End Sub
Private Sub ComboBox1_Change()
'--- On enregistre le code produit
If IsNumeric(Me.ComboBox1.Value) Then code = CLng(Me.ComboBox1.Value) Else: code = Me.ComboBox1.Value
'--- On modifie la valeur du Label
tbLabel = dProd(code)
'--- On calcule le prix unitaire
'- On enregistre les CodeMatPrem et Qu
For i = LBound(tMat) To UBound(tMat)
    If tMat(i, 1) = code Then
        dMat(tMat(i, 2)) = tMat(i, 3)
    End If
Next i
'- On boucle
For Each d In dMat.Keys
    dPrixU(d) = dMat(d) * dPrix(d)
Next d
'- On modifie la valeur du prix
tbPrix = Application.Sum(dPrixU.Items)
'--- On modifie la valeur du complément le plus onéreux
tbOnereux = Application.Max(dPrixU.Items)
'--- On vide les dictionary
dMat.RemoveAll
dPrixU.RemoveAll
End Sub

1 pièce(s) jointe(s)

Bonsoir,

Le + simple serait avec une reqête SQL

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
Sub essai()
  Dim MyArray1(2, 2)
  MyArray1(0, 0) = "ID"
  MyArray1(0, 1) = "Client"
  MyArray1(0, 2) = "Prix"
  MyArray1(1, 0) = "ID1"
  MyArray1(1, 1) = "Client A"
  MyArray1(1, 2) = 20
  MyArray1(2, 0) = "ID2"
  MyArray1(2, 1) = "Client B"
  MyArray1(2, 2) = 30
 
  Dim MyArray2(2, 1)
  MyArray2(0, 0) = "ID"
  MyArray2(0, 1) = "Quantité"
  MyArray2(1, 0) = "ID2"
  MyArray2(1, 1) = 5
  MyArray2(2, 0) = "ID1"
  MyArray2(2, 1) = 2
 
'[A2].Resize(UBound(MyArray1) + 1, UBound(MyArray1, 2) + 1) = MyArray1
'[G2].Resize(UBound(MyArray2) + 1, UBound(MyArray2, 2) + 1) = MyArray2
 
  Dim TblResult(2, 4)
  Set d = CreateObject("scripting.dictionary")
  For i = 0 To UBound(MyArray2)
    d(MyArray2(i, 0)) = MyArray2(i, 1)
  Next i
 
  For i = 1 To UBound(MyArray1)
    For k = 0 To 2
      TblResult(i, k) = MyArray1(i, k)
    Next k
    TblResult(i, 3) = d(MyArray1(i, 0))
    TblResult(i, 4) = d(MyArray1(i, 0)) * TblResult(i, 2)
  Next i
  For k = 0 To 2: TblResult(0, k) = MyArray1(0, k): Next k
  TblResult(0, 3) = MyArray2(0, 1)
  TblResult(0, 4) = MyArray2(0, 1) & "*" & MyArray1(0, 2)
  [K2].Resize(UBound(TblResult) + 1, UBound(TblResult, 2) + 1) = TblResult
End Sub

Boisgontier

ID	Client	Prix	Quantité	Prix * Quantité
ID1	Cleint A	20	2	40
ID2	Client B	30	5	150