Fusionner deux tableaux sous VBA
Bonjour à toutes et à tous.
Je suis débutante en vba et aurais besoin d'une aide charitable.
Mon objectif :
Je possède deux tableaux sur deu feuilles différentes d'un classeur.
Les deux tableaux sont différents (en taille et en contenu) mis à part la colonne livraison qui dot etre commune mais qui ne posséde pas totalement les memes numéros de livraison.
Mon but : J'aimerais fusionner mes deux tableaux en un seul qui contiendrait toutes les infos nécessaire en fonction du numéro de lot de controle et de livraison.
Je mets en fichier joint les deux tableaux que je posséde ainsi ce que j'aimerais obtenir.
Je précise le tableau obtenu est fait de maniere manuel avec des RECHERCHEV trés lourdes et donc trés long et j'aimerais avoir un code vba automatique qui me le ferai de facon à pouvoir le fare sur d'autres.
Merci à tous et d'avance pour votre aide car je suis un peu perdue. =(
Julie_75
Bonjour,
Pour info il n'y a pas de fichier joint. Si ils sont trop lourds tu peux passer via ci-joint.fr
Cordialement,
Vbabeginner
Bonsoir julie_75, le forum
Essaie ceci, si j'ai bien compris.
Au préalable, crée la Feuil1.
Option Explicit
Sub test()
Dim a, i As Long, j As Long, n As Long, w(), y
a = Sheets("Export_QA32").Range("a1").CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(a, 1)
If Not .exists(a(i, 2)) Then
ReDim w(1 To 8, 1 To 1)
w(1, UBound(w, 2)) = a(i, 1): w(2, UBound(w, 2)) = a(i, 2)
.Item(a(i, 2)) = w
Else
w = .Item(a(i, 2))
ReDim Preserve w(1 To 8, 1 To UBound(w, 2) + 1)
w(1, UBound(w, 2)) = a(i, 1): w(2, UBound(w, 2)) = a(i, 2)
.Item(a(i, 2)) = w
End If
Next
a = Sheets("Export_VL06o").Range("a1").CurrentRegion.Value
For i = 2 To UBound(a, 1)
If Not .exists(a(i, 1)) Then
ReDim w(1 To 8, 1 To 1)
w(2, UBound(w, 2)) = a(i, 1)
w(3, UBound(w, 2)) = a(i, 2): w(4, UBound(w, 2)) = a(i, 3)
w(5, UBound(w, 2)) = a(i, 4): w(6, UBound(w, 2)) = a(i, 3)
w(7, UBound(w, 2)) = a(i, 6): w(8, UBound(w, 2)) = a(i, 7)
.Item(a(i, 1)) = w
Else
w = .Item(a(i, 1))
For j = 1 To UBound(w, 2)
w(3, j) = a(i, 2): w(4, j) = a(i, 3)
w(5, j) = a(i, 4): w(6, j) = a(i, 3)
w(7, j) = a(i, 6): w(8, j) = a(i, 7)
Next
.Item(a(i, 1)) = w
End If
Next
y = .items
End With
Application.ScreenUpdating = False
n = 1
With Sheets("Feuil1")
.Cells.Clear
.Columns(1).NumberFormat = "@"
With .Cells(1)
.Resize(1, 8).Value = Array("Lot de contrôle", "Livraison", "Client", _
"Poids Total", "Statut global prelevement", "Packaging", "Logistique", "Expédition (SM)")
For i = 0 To UBound(y)
With .Offset(n).Resize(UBound(y(i), 2), 8)
.Value = _
Application.Transpose(Application.Index(y(i), 0, 0))
n = n + .Rows.Count
End With
Next
With .CurrentRegion
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
With .Rows(1)
.BorderAround Weight:=xlThin
.Interior.ColorIndex = 36
End With
.Columns.AutoFit
End With
End With
.Activate
End With
Application.ScreenUpdating = True
End Subklin89
Re julie_75
Le code réajusté :
Option Explicit
Sub test()
Dim a, i As Long, j As Long, n As Long, w(), y
a = Sheets("Export_QA32").Range("a1").CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(a, 1)
If Not .exists(a(i, 2)) Then
ReDim w(1 To 8, 1 To 1)
Else
w = .Item(a(i, 2))
ReDim Preserve w(1 To 8, 1 To UBound(w, 2) + 1)
End If
w(1, UBound(w, 2)) = a(i, 1): w(2, UBound(w, 2)) = a(i, 2)
.Item(a(i, 2)) = w
Next
a = Sheets("Export_VL06o").Range("a1").CurrentRegion.Value
For i = 2 To UBound(a, 1)
If Not .exists(a(i, 1)) Then
ReDim w(1 To 8, 1 To 1)
w(2, UBound(w, 2)) = a(i, 1)
w(3, UBound(w, 2)) = a(i, 2): w(4, UBound(w, 2)) = a(i, 3)
w(5, UBound(w, 2)) = a(i, 4): w(6, UBound(w, 2)) = a(i, 3)
w(7, UBound(w, 2)) = a(i, 6): w(8, UBound(w, 2)) = a(i, 7)
Else
w = .Item(a(i, 1))
For j = 1 To UBound(w, 2)
w(3, j) = a(i, 2): w(4, j) = a(i, 3)
w(5, j) = a(i, 4): w(6, j) = a(i, 3)
w(7, j) = a(i, 6): w(8, j) = a(i, 7)
Next
End If
.Item(a(i, 1)) = w
Next
y = .items: .RemoveAll
End With
Application.ScreenUpdating = False
'Restitution
With Sheets("Feuil1").Cells(1)
With .Parent
.Cells.Clear
.Columns(1).NumberFormat = "@"
End With
.Resize(1, 8).Value = Array("Lot de contrôle", "Livraison", "Client", _
"Poids Total", "Statut global prelevement", "Packaging", "Logistique", "Expédition (SM)")
With .Offset(1)
For i = 0 To UBound(y)
w = y(i)
With .Offset(n)
.Resize(UBound(w, 2), UBound(w, 1)).Value = Application.Transpose(w)
n = n + UBound(w, 2)
End With
Next
End With
With .CurrentRegion
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
With .Rows(1)
.BorderAround Weight:=xlThin
.Interior.ColorIndex = 36
End With
.Columns.AutoFit
End With
.Parent.Activate
End With
Application.ScreenUpdating = True
End Subklin89
Re ,
Et pour ceux qui aiment tripoter les dictionnaires, on pourrait l'écrire comme ceci :
Option Explicit
Sub test()
Dim a, b(), i As Long, j As Long, n As Long, w(), e
a = Sheets("Export_QA32").Range("a1").CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(a, 1)
If Not .exists(a(i, 2)) Then
ReDim w(1 To 8, 1 To 1)
Else
w = .Item(a(i, 2))
ReDim Preserve w(1 To 8, 1 To UBound(w, 2) + 1)
End If
w(1, UBound(w, 2)) = a(i, 1): w(2, UBound(w, 2)) = a(i, 2)
.Item(a(i, 2)) = w
Next
a = Sheets("Export_VL06o").Range("a1").CurrentRegion.Value
For i = 2 To UBound(a, 1)
If Not .exists(a(i, 1)) Then
ReDim w(1 To 8, 1 To 1)
w(2, UBound(w, 2)) = a(i, 1)
w(3, UBound(w, 2)) = a(i, 2): w(4, UBound(w, 2)) = a(i, 3)
w(5, UBound(w, 2)) = a(i, 4): w(6, UBound(w, 2)) = a(i, 3)
w(7, UBound(w, 2)) = a(i, 6): w(8, UBound(w, 2)) = a(i, 7)
Else
w = .Item(a(i, 1))
For j = 1 To UBound(w, 2)
w(3, j) = a(i, 2): w(4, j) = a(i, 3)
w(5, j) = a(i, 4): w(6, j) = a(i, 3)
w(7, j) = a(i, 6): w(8, j) = a(i, 7)
Next
End If
.Item(a(i, 1)) = w
Next
'attention à la 1ère dimension
ReDim b(1 To 100, 1 To 8): n = 1
b(1, 1) = "Lot de contrôle": b(1, 2) = "Livraison"
b(1, 3) = "Client": b(1, 4) = "Poids Total"
b(1, 5) = "Statut global prelevement": b(1, 6) = "Packaging"
b(1, 7) = "Logistique": b(1, 8) = "Expédition (SM)"
For Each e In .keys
w = .Item(e)
For i = 1 To UBound(w, 2)
n = n + 1
For j = 1 To UBound(w, 1)
b(n, j) = w(j, i)
Next
Next
Next
End With
Application.ScreenUpdating = False
'Restitution
With Sheets("Feuil1")
.Cells.Clear
.Columns(1).NumberFormat = "@"
With .Cells(1).Resize(n, UBound(b, 2))
.Value = b
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
With .Rows(1)
.BorderAround Weight:=xlThin
.Interior.ColorIndex = 36
End With
.Columns.AutoFit
End With
.Parent.Activate
End With
Application.ScreenUpdating = True
End Subklin89
Bonjour klin89
J'espère quee je t'ai pas gâché ton samedi soir.
Pourquoi créé Feuil1 d'abord ? Quand j'ouvre un nouveau classeur il me l'a crée automatiquement de toute façon non ?
J'essaye cela dès demain matin merci.
Je te tiens au courant.
De plus serait il possible de créer une traçabilité qui l'enregistrerai dans un fichier toutes les livraisons expédier ( celles où il y aurait un C dans la colonne expédition) une traçabilité qui se ferait automatique des que ça détecterai la variable C dans expédition ?
Merci d'avance klin89 =) =) =) tu es une génie