XL 2010 VBA : Boucle For each qui ne s'arrête pas

Sub EffaceDoublons()
Dim Plg As Range, Cell As Range, donnée1 As String, donnée2 As String
    With WorkSheets("Feuil1")
        Set Plg = .Range("F6:F" & .Range("G1048576").End(xlUp).Row)
        With Plg
            With .Resize(, 2)
                With .Borders: .LineStyle = xlContinuous: .Item(xlInsideHorizontal).LineStyle = xlNone: End With
                .VerticalAlignment = xlCenter
                .UnMerge
            End With
        End With
        For Each Cell In Plg
            If Cell.Value = donnée1 Then Cell.ClearContents Else donnée1 = Cell.Value
        Next
        For Each Cell In Plg
            If Cell.Value <> "" Then
                On Error Resume Next
                With .Range(.Range(donnée1), .Range(donnée2))
                    With .Resize(, 2).Borders: .LineStyle = xlContinuous: .Item(xlInsideHorizontal).LineStyle = xlNone: End With
                    .Merge
                End With
                On Error GoTo 0
                donnée1 = Cell.Address
            End If
            donnée2 = Cell.Address
        Next
        With .Range(.Range(donnée1), .Range(donnée2))
            With .Resize(, 2).Borders: .LineStyle = xlContinuous: .Item(xlInsideHorizontal).LineStyle = xlNone: End With
            .Merge
        End With
    End With
End Sub