Microsoft 365 Réorganiser les données selon la clé

[VBA_dev_Anne_Marie]

Bonjour,

J'ai une question : est-ce qu'il existe un algorithme VBA simple pour réorganiser ce genre de données ou bien il faut passer par ADODB ?

Input :

Output :

Merci pour votre aide !

 

[mapomme]

Bonjour @VBA_dev_Anne_Marie ,

On ne peut rien tester sur une image . Joignez un classeur représentatif anonymisé avec quelques lignes de donnée (la source et l'attendu).

En regardant l'image, je déduis qu'il suffit de supprimer la 2eme colonne "Code 1" ; ce n'est certainement pas ça .

 

[cp4]

Bonjour,

En adaptant à ton exemple ce code du regretté Jacques Boisgontier, à tester en supposant que ton tableau commence en A1.

Option Explicit

Sub fusion()
   Dim d1 As Object, a, b, c, n As Integer, m As Integer, i As Integer, p As Integer
   Set d1 = CreateObject("Scripting.Dictionary")
   With ActiveSheet
      a = .Range("A1:B" & .Range("A" & Rows.Count).End(xlUp).Row)
      b = .Range("C1:D" & .Range("A" & Rows.Count).End(xlUp).Row)
      n = UBound(a) + UBound(b)
      ReDim c(1 To n, 1 To 3)
      m = 0
      For i = LBound(a) To UBound(a)
         If Not d1.exists(a(i, 1)) Then m = m + 1: d1(a(i, 1)) = m: p = m Else p = d1(a(i, 1))
         c(p, 1) = a(i, 1): c(p, 2) = a(i, 2)
      Next i
      For i = LBound(b) To UBound(b)
         If Not d1.exists(b(i, 1)) Then m = m + 1: d1(b(i, 1)) = m: p = m Else p = d1(b(i, 1))
         c(p, 1) = b(i, 1): c(p, 3) = b(i, 2)
      Next i
      .[G1].CurrentRegion.ClearContents
      .[G1].Resize(d1.Count, UBound(c, 2)) = c
   End With
End Sub

Bonne journée.

 

[VBA_dev_Anne_Marie]

Bonjour,

En adaptant à ton exemple ce code du regretté Jacques Boisgontier, à tester en supposant que ton tableau commence en A1.

Option Explicit

Sub fusion()
   Dim d1 As Object, a, b, c, n As Integer, m As Integer, i As Integer, p As Integer
   Set d1 = CreateObject("Scripting.Dictionary")
   With ActiveSheet
      a = .Range("A1:B" & .Range("A" & Rows.Count).End(xlUp).Row)
      b = .Range("C1:D" & .Range("A" & Rows.Count).End(xlUp).Row)
      n = UBound(a) + UBound(b)
      ReDim c(1 To n, 1 To 3)
      m = 0
      For i = LBound(a) To UBound(a)
         If Not d1.exists(a(i, 1)) Then m = m + 1: d1(a(i, 1)) = m: p = m Else p = d1(a(i, 1))
         c(p, 1) = a(i, 1): c(p, 2) = a(i, 2)
      Next i
      For i = LBound(b) To UBound(b)
         If Not d1.exists(b(i, 1)) Then m = m + 1: d1(b(i, 1)) = m: p = m Else p = d1(b(i, 1))
         c(p, 1) = b(i, 1): c(p, 3) = b(i, 2)
      Next i
      .[G1].CurrentRegion.ClearContents
      .[G1].Resize(d1.Count, UBound(c, 2)) = c
   End With
End Sub

Bonne journée.

Merci, malheureusement, le code ne donne pas le résultat attendu.

Voici le résultat du code :

Mon input est :

Mon output attendu :

J'ai joint le fichier avec le code.

Bonne journée !

 

[cp4]

Merci, malheureusement, le code ne donne pas le résultat attendu.

Voici le résultat du code :
Regarde la pièce jointe 1156618
Mon input est :
Regarde la pièce jointe 1156619
Mon output attendu :
Regarde la pièce jointe 1156620

J'ai joint le fichier avec le code.

Bonne journée !

@VBA_dev_Anne_Marie : Sans fichier, vous vous attendiez à un miracle. Il fallait joindre votre fichier.
Le code fusionne 2 Arrays, il vous suffit d'adapter les plages.
J'ai fait un fichier par rapport aux images éditées dans le message initial et ça fonctionne bien.

 

[VBA_dev_Anne_Marie]

@VBA_dev_Anne_Marie : Sans fichier, vous vous attendiez à un miracle. Il fallait joindre votre fichier.
Le code fusionne 2 Arrays, il vous suffit d'adapter les plages.
J'ai fait un fichier par rapport aux images éditées dans le message initial et ça fonctionne bien.

Etrange, je copie-colle le code, mais il ne marche pas chez moi :

Le fichier est ci joint.

 

[cp4]

Etrange, je copie-colle le code, mais il ne marche pas chez moi :

Regarde la pièce jointe 1156665

Le fichier est ci joint.

Le résultat est bon, le code fonctionne parfaitement.
Évidemment, le rendu n'est pas bon vu que tu n'adaptes pas à ton cas.
En effet, tes données commencent en A4 et B4. Je t'avais bien dit au post#3 ==> à supposer que ton tableau commence en A1.

a = .Range("A1:B" & .Range("A" & Rows.Count).End(xlUp).Row)' Remplace A1 par A4'
b = .Range("C1:D" & .Range("A" & Rows.Count).End(xlUp).Row)' Remplace C1 par C4'

A+

 

[dysorthographie]

Bonjour,
je m'y colle également!

 

[VBA_dev_Anne_Marie]

Bonjour,
je m'y colle également!

Merci, ça marche bien !
Pourriez-vous commenter le code pour que puisse mieux comprendre ?

Merci !

 

[dysorthographie]

il y avait des erreur que J'ai corrigé!

Sub test()
Dim Code1 As Object: Set Code1 = CreateObject("Scripting.Dictionary") 'Ici j'instenci une collection
'Un Dictionary comporte Un Clé {Key} et une Valeur
'Code1.exists("TOTO") retourn true si TOTO existe dans la collection
'Code1.Add "TOTO",10 ajoute la clé TOTO a la collection avec la valeur 10
'MsgBox  Code1("TOTO") afichie un le message 10!
Dim L As Integer, Out As Range
Set Out = ThisWorkbook.Sheets("Feuil1").Range("F1") 'ici Je mémorise la première célulle de mon table de sorti

'jesuprime tout ce sui ce trouve en desous de la     barre de tire, en rouge,de mon tableau de sortie!
With Out.CurrentRegion
If .Cells.Rows.Count > 1 Then Range(.Range("A2"), .Cells(.Cells.Rows.Count, "C")).Delete
End With

With ThisWorkbook.Sheets("Feuil1").Range("A1").CurrentRegion 'je memorise mon tableau d'entré en jaune
For i = 2 To .Rows.Count 'je parcour mon tableau d'entré de la ligne 2 à la dernière
If Trim(.Cells(i, "A").Value) <> "" Then 'notes que dans une plage la première celulle est toujour A1 Range("C10").range("A1")="TOTO"
'Code1 sauvegarde la ligne ou serra sauvegardé les code P048A se fera à la ligne 2 te tableau de sortie en rose
If Not Code1.exists(.Cells(i, "A").Value) Then Code1.Add .Cells(i, "A").Value, Out.CurrentRegion.Rows.Count + 1
Out.Cells(Code1(.Cells(i, "A").Value), "A") = .Cells(i, "A") 'en  Out.Cells(Code1("P048A"), "A")="P048A" par exemple
Out.Cells(Code1(.Cells(i, "A").Value), "B") = .Cells(i, "B") 'en  Out.Cells(Code1("P048A"), "B")="1" par exemple
End If
If Trim(.Cells(i, "C").Value) <> "" Then
If Not Code1.exists(.Cells(i, "C").Value) Then Code1.Add .Cells(i, "C").Value, Out.CurrentRegion.Rows.Count + 1 'P048D Par Exemple
Out.Cells(Code1(.Cells(i, "C").Value), "A") = .Cells(i, "C") 'en  Out.Cells(Code1("P048A"), "A")="P048A" par exemple
Out.Cells(Code1(.Cells(i, "C").Value), "C") = .Cells(i, "D") 'en  Out.Cells(Code1("P048A"), CA")="2" par exemple
End If

Next
End With
End Sub