Sub ShortingReport()
    
    Dim rng As Range
    Dim i As Integer
    Dim diapazon As String
   
    'Здесь меняем диапазон
    diapazon = "A1:A15"
    
    Application.StatusBar = "Идет сокращение отчета..."
    Application.ScreenUpdating = False
    
    With ActiveSheet
    
        'проверка списка на достаточное кол-во позиций. 2 минимум.
        If .Range(diapazon).Cells( 1 ,  1 ).End(xlDown).Row >=  65535  Then
            MsgBox "Список отчета менее 2-ух позиций!" & Chr( 13 ) & Chr( 10 ) & _
                "Попробуйте проанализировать его вручную."
            Exit Sub
        End If
    
        i =  0 
        
        Do
    
            Set rng = .Range(diapazon).Find( _
                What:=.Range(diapazon).Offset(i,  0 ).Value, _
                LookIn:=xlValues, _
                LookAt:=xlWhole, _
                MatchCase:=False)
       
            If Not (rng Is Nothing) Then

                Do Until (rng Is Nothing) Or _
                    (.Range(diapazon).Cells( 1 ,  1 ).Offset(i,  0 ).Address = .Range(diapazon).Cells( 1 ,  1 ).End(xlDown).Address)
                    .Rows(rng.Row).Delete Shift:=xlUp
                    Set rng = .Range(.Range(diapazon).Cells( 1 ,  1 ).Offset(i +  1 ,  0 ), .Range(diapazon).Cells( 1 ,  1 ).End(xlDown)).FindNext
                Loop
            End If
        
        i = i +  1 
    
        Loop While .Range(diapazon).Cells( 1 ,  1 ).Offset(i -  1 ,  0 ).Address <> .Range(diapazon).Cells( 1 ,  1 ).End(xlDown).Address

    End With
    Application.ScreenUpdating = True
    Application.StatusBar = ""
    
End Sub