Suppression doublon en ligne mais pas en colonne

Sub SuppDoublon()
Dim shaux As Worksheet, shact As Worksheet, xrg As Range
  Application.ScreenUpdating = False
  Set shact = ActiveSheet
  Set shaux = ThisWorkbook.Sheets.Add
  With shaux
    shact.Range("A1").CurrentRegion.Copy
    .Range("A1").PasteSpecial , , , True
    For Each xrg In .Range("A1").CurrentRegion.Columns
      xrg.RemoveDuplicates Columns:=1, Header:=xlYes
    Next xrg
    shact.Range("A1").CurrentRegion.Clear
    .Range("A1").CurrentRegion.Copy
    shact.Range("A1").PasteSpecial , , , True
    .Application.DisplayAlerts = False
    .Delete
    Application.DisplayAlerts = True
  End With
  Application.Goto shact.Range("A1"), True
  Application.ScreenUpdating = True
End Sub

Sub SuppDoublon()
Const pas = 16384
Dim shaux As Worksheet, shact As Worksheet, xrg As Range
Dim lig&, col&, i&, deb&, fin&, T0 As Single

  T0 = Timer
  Application.ScreenUpdating = False
  Set shact = ActiveSheet
  Set xrg = shact.Range("A1").CurrentRegion
  lig = xrg.Rows.Count: col = xrg.Columns.Count
  Set shaux = ThisWorkbook.Sheets.Add
  deb = 1
  
With shaux
  Do
    With shact
      fin = IIf(deb + pas > lig, lig, deb + pas - 1)
      .Range(.Cells(deb, 1), .Cells(fin, col)).Copy
    End With
    
    .Range("A1").PasteSpecial , , , True
    For Each xrg In .Range("A1").CurrentRegion.Columns
      xrg.RemoveDuplicates Columns:=1, Header:=xlYes
    Next xrg
    shact.Range(shact.Cells(deb, 1), shact.Cells(fin, col)).Clear
    .Range("A1").CurrentRegion.Copy
    shact.Cells(deb, 1).PasteSpecial , , , True
    .Cells.Delete
    deb = fin + 1
  Loop Until deb > lig
  .Application.DisplayAlerts = False
  .Delete
  Application.DisplayAlerts = True
End With

  Application.Goto shact.Range("A1"), True
  Application.ScreenUpdating = True
  MsgBox "Durée: " & Format(Timer - T0, "0.0 sec")
End Sub

Option Explicit
Sub Sup_Doublon()
Dim c&, i&, j&, l&
Application.ScreenUpdating = 0
j = [A65536].End(xlUp).Row
For i = 2 To j
  c = Cells(i, Columns.Count).End(xlToLeft).Column
  For l = c To 2 Step -1
    If Application.CountIf(Rows(i), Cells(i, l)) > 1 Then Cells(i, l).Delete Shift:=xlToLeft
  Next
Next
Application.ScreenUpdating = -1
End Sub

Sub supDoublons()
 For i = 1 To [A65000].End(xlUp).Row
   a = Cells(i, 1).Resize(, Cells(i, "IV").End(xlToLeft).Column).Value
   Set d = CreateObject("Scripting.Dictionary")
   For Each c In a: d(c) = "": Next c
   Sheets("result").[a1].Offset(i).Resize(, d.Count) = d.keys
 Next i
End Sub

Option Explicit

Sub SuppDoublonMP()
Const pas = 16384
Dim shact As Worksheet, xrg As Range
Dim lig&, col&, i&, j&, k&, deb&, fin&, t0 As Single
Dim dico As New Dictionary, T

  t0 = Timer
  Application.ScreenUpdating = False
  Set shact = ActiveSheet
  Set xrg = shact.Range("A1").CurrentRegion
  lig = xrg.Rows.Count: col = xrg.Columns.Count
  deb = 1
  
  With shact
    Do
      fin = IIf(deb + pas > lig, lig, deb + pas - 1)
      T = .Range(.Cells(deb, 1), .Cells(fin, col)).Value
      For i = 1 To fin + 1 - deb
        dico.RemoveAll
        k = 0
        For j = 1 To col
          If T(i, j) <> "" Then
            If Not dico.Exists(T(i, j)) Then
              k = k + 1
              T(i, k) = T(i, j)
              dico.Add T(i, j), ""
            End If
          End If
        Next j
        For j = k + 1 To col
          T(i, j) = ""
        Next j
      Next i
      .Range(.Cells(deb, 1), .Cells(fin, col)).Clear
      .Range(.Cells(deb, 1), Cells(fin, col)).Value = T
      deb = fin + 1
    Loop Until deb > lig
  End With

  Application.Goto shact.Range("A1"), True
  Application.ScreenUpdating = True
  MsgBox "Durée: " & Format(Timer - t0, "0.0 sec")

End Sub