Extraction sans doublon issue de plusieurs colonnes avec ordre alphabétique
Bonjour
J'ai regardé sur les différents posts mais je n'ai pas trouvé mon bonheur.
J'ai 1 onglet 'Fournisseur 1' qui a les colonnes suivantes :
et 1 onglet 'Fournisseur 2' qui a les colonnes suivantes :
Ensuite un onglet 'Synthèse' qui doit reprendre les 2 précédents en regroupant les doublons calculés sur 2 colonnes (A et B) et en affichant les noms des produits pour les 2 fournisseurs sachant que ces noms peuvent être différents pour un même duo 'Référence/Type') et en classant par ordre alphabétique.
Ci-dessous le résultat attendu :
J'espère que mon explication est suffisamment claire et que quelqu'un aura le temps de se pencher sur mon cas épineux...
D'avance Merci
Mardel
Bonsoir à tous !
Connaissez-vous Power Query ?
Compte tenu de votre Excel, il sera nécessaire d'installer un complément gratuit Microsoft (Nativement intégré dans Excel à partir de 2016). Ensuite en quelques clics, Power Query vous retournera un tableau structuré conforme à votre besoin.
Au besoin, joignez un classeur représentatif.
Bonsoir JFL
Je ne connais pas Power Query. Je n'en ai même jamais entendu parler.
J'ai regardé sur internet et je n'ai pas compris grand chose mais je vais persister.
Je joint le fichier 'Test' correspondant à ma demande.
Cordialement
Mardel
Bonsoir de nouveau à tous !
Je vous livre une proposition via Power Query :
J'ai chargé dans Power Query deux tableaux structurés (t_Four1 et t_Four2) préalablement insérés dans le classeur.
Divers "traitements" sur les données chargées sont appliqués pour retourner le résultat attendu. Pour en prendre connaissance : clic droit dans le tableau retourné, puis "Table .../ Modifier la requête". Cela ouvrira la fenêtre de l'éditeur Power Query, les étapes appliquées étant à droite de la fenêtre.
Bonsoir à tous,
Une autre façon de procéder :
Option Explicit
Sub fusion()
Dim a, w(), e, i As Long, t As Byte, txt As String, dico As Object
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1: t = 0
For Each e In Array("Fournisseur 1", "Fournisseur 2")
a = Sheets(e).Cells(1).CurrentRegion.Value
For i = 2 To UBound(a, 1)
txt = Join(Array(a(i, 1), a(i, 2)), Chr(2))
If Not dico.exists(txt) Then
ReDim w(1 To 7)
w(1) = a(i, 1): w(2) = a(i, 2)
Else
w = dico(txt)
End If
w(3 + t) = a(i, 3)
w(5 + t) = w(5 + t) + a(i, 4)
dico(txt) = w
Next
t = t + 1
Next
For Each e In dico.keys
w = dico(e)
w(7) = w(5) + w(6)
dico(e) = w
Next
Application.ScreenUpdating = False
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Restitution").Delete
Sheets.Add().Name = "Restitution"
On Error GoTo 0
With Sheets("Restitution").Cells(1)
.Resize(, 7) = Array("Référence", "Type", "Nom F1", "Nom F2", "Stock F1", "Stock F2", "Total")
.Offset(1).Resize(dico.Count, 7).Value = Application.Index(dico.items, 0, 0)
With .CurrentRegion
.VerticalAlignment = xlCenter
.Font.Name = "calibri"
.Font.Size = 10
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
With .Rows(1)
.Interior.ColorIndex = 43
.HorizontalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Font.Size = 11
End With
.Columns("a:d").HorizontalAlignment = xlCenter
'.Columns.AutoFit
End With
End With
Set dico = Nothing
Application.ScreenUpdating = True
End Subklin89
Merci à tous les 2
Pour JFL : j'ai téléchargé Power Query.
Peut-on avoir une mise à jour automatique dans 'Synthèse' sans avoir à cliquer sur 'Actualiser' dans 'Outils de tableau/création' ?
Pour Klin89 :
J'ai copié le VBA proposé dans le VBA de 'Synthèse'. ça fonctionne sauf que le résultat n'est pas par ordre alphabétique :
Et même question que pour JFL : peut-on avoir une mise à jour automatique dans 'Synthèse' sans macro ?
Désolé de tous ces tracas.
Cordialement
Mardel
Merci tulipe_4
Il y des fonctions que je ne connais pas du tout :
ça fonctionne sauf quand on fait une modification sur les 2 onglets F1 et F2. Dans ce cas dans 'param' il y a des #NOM? et des #REF!
et l'écran 'Synthèse' est vierge.
Je n'ai pas dû tout piger.
Cordialement
Mardel
c'est à cause de ton xl 2013 qui ne veux pas des # (je n'avais pas fais attention )
je vais essayer d' adapter pour une version rustique
Re MARDEL,
Tu rajoutes la dernière ligne ci-dessous :
With Sheets("Restitution").Cells(1)
.Resize(, 7) = Array("Référence", "Type", "Nom F1", "Nom F2", "Stock F1", "Stock F2", "Total")
.Offset(1).Resize(dico.Count, 7).Value = Application.Index(dico.items, 0, 0)
.Sort key1:=.Cells(1), order1:=1, Header:=xlYesBonnes fêtes à tous
klin89
Merci Klin89
ça fonctionne.
As-tu regardé ma question subsidiaire : peut-on avoir une mise à jour automatique dans 'Restitution' sans macro ?
Merci encore
Cordialement
Mardel
Bonjour à tous,
@Klin89: Bravo pour ton code
J'ai essayé de l'adapter pour travailler avec des tableaux structurés:
Mon pauvre cerveau peine à tout comprendre
dico.CompareMode = 1Pourquoi le Chr(2) ici ?
txt = Join(Array(a(i, 1), a(i, 2)), Chr(2))De même, je ne comprends pas:
For Each e In dico.keys
w = dico(e)
w(7) = w(5) + w(6)
dico(e) = w
NextIl semblerai que j’obtienne le même résultat avec:
w(3 + t) = a(i, 3)
w(5 + t) = w(5 + t) + a(i, 4)
w(7) = w(5) + w(6)Cordialement,
@Xorsankukai,
1=vbTextCompare = majuscules en miniscules n'ont pas d'importance pour créer un clef (key) unique. On utilise cela souvent avec de noms, parce que, là, on a souvent des conflicts.
chr(2) est un charactère invisible qu'on utilise jamais dans des textes et qui sépare bien les 3 parties.
Bonjour BsAlv,
Merci pour ces précisions,
[Edit] : et merci pour la variante sur le ListObject,
Cordialement,
re,
on peut cumuler directement dans le boucle
w(3 + t) = a(i, 3)
w(5 + t) = w(5 + t) + a(i, 4)
w(7) = w(7) + a(i, 4) 'cumuler directement le stock
et puis pour les tableaux structurés
With Sheets("Synthèse").ListObjects(1)
If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
Select Case dico.Count
Case 0
Case 1: .ListRows.Add.Range.Resize(, 7).Value = Application.Transpose(Application.Transpose(dico.items))
Case Else: .ListRows.Add.Range.Resize(dico.Count, 7).Value = Application.Index(dico.items, 0, 0)
End Select
.Range.Sort key1:=.HeaderRowRange.Cells(1), order1:=1, Header:=xlYes
End WithMerci BsAlv pour ce complément d'informations.
Xorsankukai, il faut que je m'y mette aux tableaux structurés et à Power Query ... quand j'aurai un peu de temps devant moi.
Pour la dernière boucle, c'est pour voir si tu suivais
klin89
Un grand merci à tous les intervenants.
Les solutions proposées me conviennent. Il s'agit maintenant de choisir la plus pertinente et la plus simple.
Cordialement
Mardel
re, c'est peut-être trop, mais il y a une mise à jour avec 2 méthodes dans thisworkbook.
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If StrComp(Sh.Name, "synthèse", 1) = 0 Then fusion 'update tableau quand on active la feuille "synthèse"
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Select Case UCase(Sh.Name) 'nom de la feuille en majuscules
Case "FOURNISSEUR 1", "FOURNISSEUR 2"
On Error Resume Next
If Intersect(Target, Sh.Range("A1").ListObject.DataBodyRange) Then fusion 'si on change quelque chose dans un de ces tableaux
On Error GoTo 0
End Select
End Sub