Remplacement de lignes et supp de la plus pleine

Bonjour,

Je viens vous solliciter sur une partie de macro que je désire réaliser. Dans un tableau à en-tête, on retrouve des doublons après import des lignes d'un autre tableau, c'est à dire des lignes ayant le même nom en colonne A, qu'importe les autres colonnes. On souhaite garder celui des deux doublons (si il existe) ayant le nombre de colonne le plus rempli.

J'ai pensé à cela et ça ne fonctionne pas vraiment :

Private Sub SD()

    MaCellule = "A2"
    Range(MaCellule).Select
    ActiveCell.CurrentRegion.Sort Key1:=Range(MaCellule), Order1:=xlAscending, Header:=xlYes
    Donnee1 = ActiveCell
    Ligne1 = ActiveCell.Row
    Ligne2 = ActiveCell.Offset(1, 0).Row

    While ActiveCell <> ""
        ActiveCell.Offset(1, 0).Select
        Nb1 = WorksheetFunction.CountA(Worksheets("BDD").Rows(Ligne1))
        Nb2 = WorksheetFunction.CountA(Worksheets("BDD").Rows(Ligne2))
        If ActiveCell = Donnee1 and Nb1<>Nb2 Then
            ActiveCell.Offset(-1, 0).Select
            ActiveCell.EntireRow.Delete

            Donnee1 = ActiveCell
            Ligne1 = ActiveCell.Row
            Ligne2 = ActiveCell.Offset(1, 0).Row
        End If
    Wend

End Sub

Cette macro compare chaque ligne avec la suivante, il faut faire un tri alphabétique par nom avant (c'est un autre histoire mais pas réussi non plus à amorcer ce code-ci !)

Un grand merci pour votre aide en tout cas !

Bonjour,

Je te propose une autre macro qui devrait faire le travail

J’ai modifié un peu tes exemples pour faire des essais plus poussés.

A te relire.

Sub xx()
Dim i As Integer, j As Byte, Compteur_Bas As Byte, Compteur_Haut As Byte

Application.ScreenUpdating = False

For i = Range("A" & Rows.Count).End(xlUp).Row To 3 Step -1
    If Range("A" & i) = Range("A" & i - 1) Then
        For j = 1 To 7
            If Cells(i, j) <> "" Then Compteur_Bas = Compteur_Bas + 1
            If Cells(i - 1, j) <> "" Then Compteur_Haut = Compteur_Haut + 1
        Next j
        If Compteur_Bas > Compteur_Haut Then
            Range("A" & i - 1 & ":G" & i - 1).Delete Shift:=xlUp
        Else
            Range("A" & i & ":G" & i).Delete Shift:=xlUp
        End If
    End If
Next i
End Sub

Super ça marche merci !