Code VBA suppression doublon + coller la ligne du doublon à la suite

Bonjour,

J'aimerai sur un fichier excel: supprimer les doublons et en même temps copier la ou les lignes des doublons à la suite de la ligne restante.

Quand j'exporte mes données en excel, les dates de visites apparaissent les uns en dessous des autres.

petit exemple: en PJ. j'ai mis un fichier simple en PJ.

je vous remercie!

bonjour,

une proposition

Sub aargh()
    Dim res(), lastcol()
    With ActiveSheet
        dl = .Cells(Rows.Count, 1).End(xlUp).Row
        ReDim res(1 To dl, 1 To 100) 'tableau résultats 100 colonnes maximum
        ReDim lastcol(1 To dl)
        Set dict = CreateObject("scripting.dictionary")
        'copie entête de colonne dans tableau résultat
        For i = 1 To 3
            res(1, i) = .Cells(4, i)
        Next i
        For i = 4 To 99 Step 2
            res(1, i) = .Cells(4, 4)
            res(1, i + 1) = .Cells(4, 5)
        Next
        ctr = 1
        ' traitement des lignes avec id
        For i = 5 To dl
            idn = .Cells(i, 1)
            If dict.exists(idn) Then
                ptr = dict(idn)
            Else
                ctr = ctr + 1
                ptr = ctr
                dict(idn) = ptr
                res(ptr, 1) = idn
                res(ptr, 2) = .Cells(i, 2)
                res(ptr, 3) = .Cells(i, 3)
                lastcol(ptr) = 4
            End If
            col = lastcol(ptr)
            If col > maxcol Then maxcol = col
            res(ptr, col) = .Cells(i, 4)
            res(ptr, col + 1) = .Cells(i, 5)
            lastcol(ptr) = col + 2
        Next i
    End With
    'copie du tableau résultats dans une nouvelle feuille
    Set wsr = Sheets.Add
    With wsr
        With .Cells(1, 1).Resize(ctr, maxcol + 1)
            .Value = res
            .HorizontalAlignment = xlCenter
            .Borders.Weight = xlThin
            .Columns.AutoFit
        End With
    End With
End Sub

Merci beaucoup pour cette proposition.

En exécutant cette macro, la ligne 129 disparait. Le reste fonctionne normalement.

Les entêtes des colonnes ne se copient pas.

bonjour,

le code fonctionne sur les données que tu as mises. si tu veux de l'aide sur ce point, merci de mettre un fichier (anonymisé) dans lequel tu as pu reproduire le problème.

Les entêtes des colonnes ne se copient pas.

la macro copie les entêtes qui sont en ligne 4. et d'une manière générale, la macro est faite pour fonctionner avec le fichier dont la structure correspond à celui que tu as mis à disposition. Donc il faut respecter les colonnes utilisées, les lignes où commencent les titres et les données, Par contre la macro s'adapte automatiquement au nombre de lignes, à condition que le reste soit respecté. (càd, tableau dans les colonnes A à E (id,ddn,genre,date test et resultat test : dans cet ordre.), en-têtes en ligne 4, données à partir de la ligne 5)

ok merci beaucoup; effectivement cela fonctionne sur le fichier original.

je vous ai mis le type de base sur laquelle on travaille en PJ. je pensais que le code fonctionnait sous forme de boucle.

je l'ai testé sur cette base et ça m'a copié les 3 premières colonnes et le doublon était bien copié à la suite.

merci

re-bonjour,

voici un code adapté au nouveau fichier. (dans cette version toute la ligne est copiée en cas d'id identique). Cette version est également beaucoup moins rapide.

Sub aargh()
    Dim lastcol()
    Set wsb = Sheets("base") 'feuille source
    Set wsr = Sheets.Add 'feuille résultat
    With wsb
        dl = .Cells(Rows.Count, 1).End(xlUp).Row
        Set dict = CreateObject("scripting.dictionary")
        'copie entête de colonne dans feuille résultat
        dc = .Cells(1, Columns.Count).End(xlToLeft).Column 'dernière colonne titre
        wsr.Cells(1, 1).Resize(1, dc) = wsb.Cells(1, 1).Resize(1, dc).Value 'copie entêtes
        ReDim lastcol(dl) 'première colonne libre pour la copie
        ctr = 1
        ' traitement des lignes avec id
        For i = 2 To dl
            idn = .Cells(i, 1)
            If dict.exists(idn) Then
                ptr = dict(idn)
            Else
                ctr = ctr + 1
                ptr = ctr
                dict(idn) = ptr
                lastcol(ptr) = 1
            End If
            col = lastcol(ptr)
            wsr.Cells(ptr, col).Resize(1, dc) = .Cells(i, 1).Resize(1, dc).Value
            If wsr.Cells(1, col) = "" Then
                wsr.Cells(1, col).Resize(1, dc).Value = .Cells(1, 1).Resize(1, dc).Value
            End If
            col = col + dc
            lastcol(ptr) = col
             If col > maxcol Then maxcol = col
        Next i
    End With
    'mise en forme du résultat

    With wsr
        With .Cells(1, 1).Resize(ctr, maxcol - 1)
            .HorizontalAlignment = xlCenter
            .Borders.Weight = xlThin
            .Columns.AutoFit
        End With
    End With
End Sub

Bonjour,

Merci pour cette suggestion de code. Est-il possible de faire la même chose mais que dans la recopie des entêtes de colonnes nous ayons à la fin "_v1", "_v2" ... Par exemple : date_visite_v1 lors de la première copie, date_visite_v2 lors de la 2ème copie etc ?

Merci d'avance,