Sub Elimina_dato_duplicato()
'Questo codice ordina i dati nella seconda
'colonna del Foglio1 ed elimina le righe che
'contengono dati duplicati (solo una riga e lascia l'altra con il dato trovato duplicato).
Application.ScreenUpdating = False
Range("B2:B8000").Select
Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Set currentCell = Worksheets("Foglio1").Range("B2")
Do While Not IsEmpty(currentCell)
Set nextCell = currentCell.Offset(1, 0)
If nextCell.Value = currentCell.Value Then
currentCell.EntireRow.Delete
End If
Set currentCell = nextCell
Loop
Range("B2").Select
End Sub

 'Questa routine elimina tutte e due le righe doppie
 

 Sub Elina_Tutti_I_Doppioni()
 Dim LastRow As Long, K As Long, MemoCanc As Boolean
 'Questo codice ordina i dati rispetto alla
 'colonna B del Foglio1 ed elimina sia
 'le dupliche che l'origine.
 On Error GoTo 50
 With Worksheets("Foglio1")
Application.ScreenUpdating = False
 .UsedRange.Sort .Range("B2"), Header:=xlGuess
 LastRow = WorksheetFunction.CountIf(.Range("B2:B10000"), "<>")
 If LastRow > 1 Then LastRow = LastRow + 3 Else Exit Sub
 For K = LastRow To 4 Step -1
 If .Cells(K, 2) = .Cells(K - 1, 2) Then 'Finchè le trova uguali ..
 .Cells(K, 2).EntireRow.Delete '.. elimina la duplica ..
 MemoCanc = True '.. e si memorizza un flag per l'origine.
 Else 'Quando non le trova uguali ..
 If MemoCanc Then '.. entra solo se ha in memoria ..
 .Cells(K, 2).EntireRow.Delete '.. qualcosa da eliminare ..
 MemoCanc = False '.. quindi resetta.
 End If
 End If
 Next K
Application.ScreenUpdating = True
 .Range("B4").Select
 End With
 Exit Sub
50:  Application.ScreenUpdating = True: MsgBox Err.Description
 End Sub

'controlla la colonna A a partire dalla seconda riga

Sub Elina_Tutti_I_Doppioni_2()
    Dim LastRow As Long, K As Long, MemoCanc As Variant
    
    Application.ScreenUpdating = False

    With ActiveSheet
        .Columns("A").Sort .[a1], Header:=xlGuess
        LastRow = [COUNTA(A:A)]
 
        For K = LastRow To 2 Step -1
            If .Cells(K, 1) = .Cells(K - 1, 1) Or MemoCanc = .Cells(K, 1) Then
                MemoCanc = .Cells(K, 1)
                .Rows(K).EntireRow.Delete
            End If
        Next
    End With
  
    Application.ScreenUpdating = True
End Sub

Sub Cancella_Doppioni()
  Dim LastRow As Long
  Const WS As String = "Foglio1"
  Const ListCol As String = "A"
  Const StartRow As Long = 1
  LastRow = Worksheets(WS).Cells(Rows.Count, ListCol).End(xlUp).Row
  Application.ScreenUpdating = False
  With Worksheets(WS).Cells(StartRow, ListCol).Resize(LastRow - StartRow + 1)
    .Value = Evaluate("IF(COUNTIF(A" & StartRow & ":A" & LastRow & ", A" & StartRow & ":A" & LastRow & ")=1,A" & StartRow & ":A" & LastRow & ","""")")
    On Error Resume Next
    .SpecialCells(xlBlanks).Delete xlShiftUp
    On Error GoTo 0
  End With
  Application.ScreenUpdating = True
End Sub