MacroFusionSupprimer

Bonjours Hugo
Je te propose ce code :
Prenant la colonne C à traiter

Range("C1").Offset(65535, 0).End(xlUp).Select
Do While ActiveCell.Address <> Range("C1").Address
If ActiveCell = ActiveCell.Offset(-1, 0) Then
A = ActiveCell.Offset(-1, 0).Address
ActiveCell.Offset(-1, 0).EntireRow.Copy
ActiveCell.EntireRow.Select
ActiveSheet.Paste
ActiveCell.Offset(-1, 0).EntireRow.Delete
Range(A).Select
Else
ActiveCell.Offset(-1, 0).Select
End If
Loop

Ce code si il fonctionne trés bien nécessite malgré tout 40 secondes pour
traiter 1000 lignes
En partant sur le principe de trier les données par la colonne considérée
pour réunir les occurences identiques puis de vider les lignes en doublon et
de retrier le résultat obtenu on obtient la même chose mais en 4 secondes
cette fois-ci pour le même nombre de lignes mais avec un ordre chamboulé
Ci-aprés le code :
Range("C1", [C1].Offset(65535, 0).End(xlUp)).EntireRow.Select
Selection.Sort Key1:=Range("C3"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:úlse, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("C1").Offset(65535, 0).End(xlUp).Select
Do While ActiveCell.Address <> Range("C1").Address
If ActiveCell = ActiveCell.Offset(-1, 0) Then
A = ActiveCell.Offset(-1, 0).Address
ActiveCell.EntireRow.Copy
ActiveCell.Offset(-1, 0).EntireRow.Select
ActiveSheet.Paste
ActiveCell.Offset(1, 0).EntireRow.Clear
Range(A).Select
Else
ActiveCell.Offset(-1, 0).Select
End If
Loop
Range("C1", [C1].Offset(65535, 0).End(xlUp)).EntireRow.Select
Selection.Sort Key1:=Range("C3"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:úlse, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

Qu'en penses tu ???

Fais moi part de tes impressions

Bonjour à tous,
J'essaie de comparer les cellules d'une colonnen si leur contenu est
similaire de recopier le contenu de la ligne 3 vers 4 et ensuite de supprimer
la ligne 3 et anisi de suite ,ma macro ne fonctionnne pas
Pourriez vous m'aider ,
Merci pour votre aide

Sub fusionSupprimer1()
Dim i, j
i = 3
Do While Cells(i, 3).Value <> " "
If Cells(i, 3).Value = Cells(i + 1, 3).Value Then
For j = 4 To 29
If Cells(i, j) <> Cells(i + 1, j) Then
Cells(i + 1, j) = Cells(i + 1, j) & Cells(i, j)
End If
Next j
'Cells(i, 3).EntireRow.Delete

i = i + 2
Else
i = i + 1
End If
Loop
End Sub