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

djam28

XLDnaute Occasionnel
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

XLDnaute Barbatruc
Bonjour,

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

VB:
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
 
Dernière modification par un modérateur:

job75

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

Ce n'est pas facile à comprendre ni même à expliquer :
VB:
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.
 
Dernière édition:

job75

XLDnaute Barbatruc
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 :
VB:
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+
 

Pièces jointes

  • Fusionner(2).xlsm
    31.5 KB · Affichages: 8

Discussions similaires

Statistiques des forums

Discussions
298 001
Messages
1 965 025
Membres
200 809
dernier inscrit
Ksiba