Remplacement de lignes et suppression de la plus pleine [Résolu]

[Aurel59]

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 !

 

[CHALET53]

Re : Remplacement de lignes et suppression de la plus pleine

Bonjour,

A voir si...
a+

 

[Paf]

Re : Remplacement de lignes et suppression de la plus pleine

Bonjour à tous

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 !)

Le tri existe et fonctionne , c'est la ligne ActiveCell.CurrentRegion.Sort ...

Une autre version de la macro:

Private Sub SD()

    MaCellule = "A2"
    Range(MaCellule).CurrentRegion.Sort Key1:=Range(MaCellule), Order1:=xlAscending, Header:=xlYes
    DerLig = Range(MaCellule).CurrentRegion.End(xlDown).Row
    
    For i = DerLig To 2 Step -1
        If Cells(i, 1) = Cells(i + 1, 1) Then
            If WorksheetFunction.CountA(Worksheets("BDD").Rows(i + 1)) > WorksheetFunction.CountA(Worksheets("BDD").Rows(i)) Then
                Cells(i, 1).EntireRow.Delete
            Else
                MsgBox "Ligne i+1 " & i + 1
                Cells(i + 1, 1).EntireRow.Delete
            End If
        End If
    Next
    
End Sub

A+

Edit: la ligne MsgBox... est à supprimer!

 

[Aurel59]

Re : Remplacement de lignes et suppression de la plus pleine

Un grand merci j'essaye tout ça dès que j'ai deux minutes !

 

[Aurel59]

Re : Remplacement de lignes et suppression de la plus pleine

Ca fonctionne parfaitement merci !