XL 2010 fusionner 2 tableaux avec même id -macro

[djam28]

Bonjour à tous,
J'aurais besoin de vos lumières pour résoudre un problème VBA svp. Je suis novice en macro.
Voici mon problème, j'ai deux tableaux, 3 et 4 contenants une liste de patients avec des doublons (numéros patient =colonne Nip). Les deux tableaux ne sont pas identiques (contiennent un nombre de colonnes différent). Je voudrais les fusionner de façon à ce que les doublons (numéros patients identiques) se retrouvent sur la même ligne .
Autrement dit, copier toute la ligne du doublon et la mettre à la suite du patient unique. S'il y'en a plusieurs , les coller sur la même ligne l'un à la suite des autres..
Voici mes fichiers en PJ
Merci par avance
DE

 

[Hasco]

Bonjour,

Avec les deux fichiers ci-joints dans le même dossier .
la macro est dans djam28.xlsm

Sub ImporterDatasPatient()
    Dim wk As Workbook
    Dim plg1 As Range, plg2 As Range
    Dim Nips As Variant, Nips2 As Variant, idxNip As Variant
    Dim i As Integer, nbcols As Integer
   
    Application.ScreenUpdating = False
    '
    ' Obtenir le classeur source
    On Error Resume Next
    '
    ' Voir s'il est déjà ouvert
    Set wk = Workbooks("djam28-2.xlsx")
    '
    ' S'il ne l'est pas, l'ouvrir
    If wk Is Nothing Then
        Set wk = Workbooks.Open(ThisWorkbook.Path & "\djam28-2.xlsx")
    End If
    On Error GoTo 0
    '
    ' Plage destination des données
    Set plg1 = ThisWorkbook.Sheets("Feuil1").Range("A1").CurrentRegion
    '
    ' Valeurs des Nips dans un tableau en mémoire pour aller plus vite
    Nips = plg1.Columns(1).Value
    '
    ' Destination des données1
    Set plg1 = plg1.Offset(, plg1.Columns.Count).Columns(1)
    '
    ' Source des données
    Set plg2 = wk.Sheets("Feuil1").Range("A1").CurrentRegion
    '
    ' Conserver le nombre de colonnes
    nbcols = plg2.Columns.Count
    '
    ' Nips source en tableau
    Nips2 = plg2.Columns(1).Value
    '
    ' En démarrant en 1 on importe les entêtes de plg2
    For i = 1 To UBound(Nips)
        '
        ' Chercher le Nip en cours dans le tableau Nips2
        idxNip = Application.Match(Nips(i, 1), Nips2, 0)
        '
        ' S'il est trouvé, importer les données
        If Not IsError(idxNip) Then
            plg1.Cells(i, 1).Resize(1, nbcols).Value = plg2.Cells(idxNip, 1).Resize(, nbcols).Value
        End If
    Next i
    '
    ' Fermer le classeur source sans l'enregistrer
    wk.Close False
    Application.ScreenUpdating = True
End Sub

J'ai laissé la colonne Nips pour contrôle. Si vous ne voulez pas l'importez, supprimez là après.

La prochaine fois, si vous parlez macro, donnez au moins un fichier .xlsm et non .xlsx.


Cordialement

 

[Hasco]

Re,

Demandez à celui qui vous a fait cette macro.
Je passe mon chemin.

Bonne journée

 

[job75]

Bonjour,

Je constate que Roblochon a remplacé son pseudo par Hasco.

@Yeahou comment a-t-il été autorisé à le faire ?

Car Hasco était il y a quelques années le pseudo d'un membre qui a quitté le forum en demandant qu'on supprime tous ses posts...

A+

 

[job75]

@djam28, c'est moi qui ai créé la macro sur ce fil :

https://www.excel-downloads.com/thr...leaux-deux-dimensions.20055497/#post-20416670

J'ai bien précisé qu'il ne faut pas de doublon en colonnes A des 2 feuilles.

Autrement le problème n'est pas cohérent, ce qui est le cas de votre fichier.

 

[djam28]

Merci pour ton retour. Y-t-il un moyen pour contourner cette condition ou une autre façon de faire ?
Merci à tous
Bonne journée

 

[job75]

Bon je suis arrivé à faire quelque chose qui tient la route.

Ce n'est pas facile à comprendre ni même à expliquer :

Sub Fusionner()
Dim d As Object, P1 As Range, P2 As Range, nlig1&, nlig2&, ncol1%, ncol2%, i&, r As Range, n&, j&
Set P1 = Sheets("1").[A1].CurrentRegion 'à adapter
Set P2 = Sheets("2").[A1].CurrentRegion 'à adapter
nlig1 = P1.Rows.Count
nlig2 = P2.Rows.Count
ncol1 = P1.Columns.Count
ncol2 = P2.Columns.Count - 1
Application.ScreenUpdating = False
With Sheets("Fusion") 'à adapter
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    .Cells.Delete 'RAZ
    .[A1].Resize(nlig1, ncol1) = P1.Value
    .[A1].Offset(nlig1).Resize(nlig2) = P2.Columns(1).Value
    .[A1].Offset(nlig1, ncol1).Resize(nlig2, ncol2) = P2.Columns(2).Resize(, ncol2).Value
    With .[A1].CurrentRegion
        .Sort .Columns(1), xlAscending, Header:=xlYes 'tri pour regrouper
        For i = .Rows.Count To 2 Step -1
            If .Cells(i, 1) = .Cells(i - 1, 1) Then
                Set r = .Cells(Application.Match(.Cells(i, 1), .Columns(1), 0), 1).Resize(Application.CountIf(.Columns(1), .Cells(i, 1)), ncol1)
                If Application.CountA(r.Rows(1)) > 1 Then
                    n = 0
                    For j = 2 To r.Rows.Count
                        If Application.CountA(r.Rows(j)) = 1 Then n = n + 1 'compte les lignes vides
                    Next j
                    n = Application.Min(n, r.Rows.Count - n)
                    With r.Offset(r.Rows.Count - n, ncol1).Resize(n, ncol2)
                        .Offset(n - r.Rows.Count) = .Value
                        .EntireRow.Delete
                    End With
                    i = r.Row
                End If
            End If
        Next i
        .Borders.Weight = xlThin 'bordures
        .Columns.AutoFit 'ajustement largeurs
    End With
    With .UsedRange: End With 'actualise les barres de défilement
    .Activate 'facultatif
End With
End Sub

Il n'y a plus de Dictionary ni de tableaux VBA, c'est donc moins rapide.

 

[djam28]

Job75 tu as assuré , c'est magique! Merci beaucoup. Est-ce que c'est possible que les doublons soient sur la même ligne ,un id par ligne,? si c'est possible sinon c'est très bien
Bonne soirée

 

[job75]

Les doublons sont bien placés sur la même ligne dans la mesure où c'est possible.

Je vous laisse essayer de comprendre, comme j'ai dit ce n'est pas facile.

 

[djam28]

Merci ++++ en tout cas
DE

 

[job75]

Bonjour djam28, le forum,

Le modérateur est passé par là et a supprimé tous les fichiers, il y avait sans doute des données confidentielles.

Pour que ce soit compréhensible j'ai donc adapté la macro au fichier du fil mentionné au post #5 :

Sub Fusionner()
Dim d As Object, P1 As Range, P2 As Range, nlig1&, nlig2&, ncol1%, ncol2%, i&, r As Range, n&, j&
Set P1 = Sheets("1").[A1].CurrentRegion.Offset(1) 'à adapter
Set P2 = Sheets("2").[A1].CurrentRegion.Offset(1) 'à adapter
nlig1 = P1.Rows.Count
nlig2 = P2.Rows.Count
ncol1 = P1.Columns.Count
ncol2 = P2.Columns.Count - 1
Application.ScreenUpdating = False
With Sheets("Fusion") 'à adapter
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    .Cells.Delete 'RAZ
    P1.Rows(0).Copy .[A1] 'en-têtes
    P2(0, 2).Resize(, ncol2).Copy .[A1].Offset(, ncol1) 'en-têtes
    .[A2].Resize(nlig1, ncol1) = P1.Value
    .[A2].Offset(nlig1).Resize(nlig2) = P2.Columns(1).Value
    .[A2].Offset(nlig1, ncol1).Resize(nlig2, ncol2) = P2.Columns(2).Resize(, ncol2).Value
    With .UsedRange
        .Sort .Columns(1), xlAscending, Header:=xlYes 'tri pour regrouper
        .Rows(.Rows.Count).EntireRow.Delete 'la dernière ligne est vide
        For i = .Rows.Count To 2 Step -1
            If .Cells(i, 1) = .Cells(i - 1, 1) Then
                Set r = .Cells(Application.Match(.Cells(i, 1), .Columns(1), 0), 1).Resize(Application.CountIf(.Columns(1), .Cells(i, 1)), ncol1)
                If Application.CountA(r.Rows(1)) > 1 Then
                    n = 0
                    For j = 2 To r.Rows.Count
                        If Application.CountA(r.Rows(j)) = 1 Then n = n + 1 'compte les lignes vides
                    Next j
                    n = Application.Min(n, r.Rows.Count - n)
                    With r.Offset(r.Rows.Count - n, ncol1).Resize(n, ncol2)
                        .Offset(n - r.Rows.Count) = .Value
                        .EntireRow.Delete
                    End With
                    i = r.Row
                End If
            End If
        Next i
        .Borders.Weight = xlThin 'bordures
        .Columns.AutoFit 'ajustement largeurs
    End With
    With .UsedRange: End With 'actualise les barres de défilement
    .Activate 'facultatif
End With
End Sub

A+

 

[djam28]

Bonjour Job75,
Merci beaucoup , c'est top!
Très bonne journée