Sub DelDuplicates()
Dim del As Long
Dim x As Integer
'Dim x As String
    If MsgBox("All Changes Will Be Saved!" & Chr( 13 ) & "Ispected Active Column." & Chr( 13 ) & "Continue?", vbExclamation + vbOKCancel, "Warning!") = vbCancel Then
     Exit Sub
     End If
     
WbPth = ActiveWorkbook.Path
WbName = ActiveWorkbook.Name
'x = (InputBox("What Column Inspected?", , 4)) * 1
'x = InputBox("What Column Inspected? (Letter)", "x", "A", 1500, 2000)
x = ActiveCell.Column
Application.ScreenUpdating = False

 strDate = Format(Now, "yyyy.mm.dd-hh.mm.ss")
 Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FolderExists("c:\Temp\") = False Then MkDir "c:\Temp"

                 ActiveWorkbook.SaveAs Filename:="c:\Temp\BackupBeforeDelDuplicates." & strDate & "." & ActiveWorkbook.Name, _
                 FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=True, CreateBackup:=False

Application.DisplayAlerts = False

                  ActiveWorkbook.SaveAs Filename:=WbPth & "\" & WbName, _
                 FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
                
Application.DisplayAlerts = False

With ActiveSheet.UsedRange
  For Each cc In .Columns(x).Cells
cikl:
    If Cells(cc.Row, x).Value = Cells(cc.Row +  1 , x).Value _
    And Cells(cc.Row +  1 , x).Value <> "" Then
        Application.StatusBar = " Working on  " & cc.Row & " Row" ' визуализация работы
        Rows(cc.Row +  1 ).EntireRow.Delete Shift:=xlUp
        del = del +  1 
       ' Rows(cc.Row + 1).EntireRow.Hidden = True
                       
       GoTo cikl
    End If
  Next
End With

Application.StatusBar = False 'сбрасываем визуализацию работы
Application.ScreenUpdating = True
MsgBox "Ok! Deleted " & del & " Rows!"
End Sub