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 !