Sub Macro1()
Dim chemin As String, fichier As String
Dim nbLignes As Integer, y As Integer, compteur As Integer
Dim tableau() As Integer
' On sauvegarde le fichier avec l'extension .tmp pour des raisons de sécurité
fichier = ThisWorkbook.FullName
fichier = Left(fichier, Len(fichier) - 4) & ".tmp"
ActiveWorkbook.SaveAs Filename:=fichier
' On commence par trier la feuille selon les identifiants
Cells.Select
Selection.Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
ActiveWindow.SmallScroll Down:=-9
' On compte le nombre de lignes
nbLignes = Cells(Rows.Count, 2).End(xlUp).Row
For y = 2 To nbLignes
' Si triplet
If Cells(y, 3) = Cells(y + 1, 3) And Cells(y, 3) = Cells(y + 2, 3) Then
Cells(y, 17) = Cells(y, 17) & Cells(y + 1, 17) & Cells(y + 2, 17)
compteur = compteur + 1
ReDim Preserve tableau(compteur)
tableau(compteur) = y + 1
compteur = compteur + 1
ReDim Preserve tableau(compteur)
tableau(compteur) = y + 2
y = y + 2
End If
' Si doublet
If Cells(y, 3) = Cells(y + 1, 3) Then
Cells(y, 17) = Cells(y, 17) & Cells(y + 1, 17)
compteur = compteur + 1
ReDim Preserve tableau(compteur)
tableau(compteur) = y + 1
y = y + 1
End If
Next y
' On détruit les lignes du bas vers le haut
For y = UBound(tableau) To 1 Step -1
Rows(tableau(y)).EntireRow.Delete Shift:=xlUp
Next y
End Sub