Sub 567()
'

'
    Range("H1").Select
    ActiveCell.FormulaR1C1 = "1"
    Range("H2").Select
    ActiveCell.FormulaR1C1 = "=RC[-5]&RC[-4]"
    Range("H2").Select
    Selection.AutoFill Destination:=Range("H2:H1000")
    Range("H2:H16").Select
    Range("H16").Select
    Selection.AutoFill Destination:=Range("H16:H119"), Type:=xlFillDefault
    Range("H16:H1000").Select
    Columns("H:H").Select
    Selection.FormatConditions.AddUniqueValues
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    Selection.FormatConditions(1).DupeUnique = xlDuplicate
    With Selection.FormatConditions(1).Font
        .Color = -16383844
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 13551615
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Rows("2:1000").Select
   
    Range("A1:H1").Select
    Range("H1").Activate
    Selection.AutoFilter
    
    Rows("2:1000").Select
  
    ActiveSheet.Range("$A$1:$H$1000").AutoFilter Field:=8, Operator:= _
        xlFilterNoFill
    Selection.Delete Shift:=xlUp
     Selection.Delete Shift:=xlUp
      Selection.Delete Shift:=xlUp
   
    ActiveSheet.Range("$A$1:$H$114").AutoFilter Field:=8
    Columns("H:H").Select
    Selection.Delete Shift:=xlToLeft
    Rows("1:1").Select
    Selection.AutoFilter
  
    End Sub

Sub sort()
Dim wb, sh, lr, f, arr(2) As Collection, k, str, t
wb = ThisWorkbook.Name
sh = ThisWorkbook.ActiveSheet.Name
lr = Workbooks(wb).Sheets(sh).Cells(Rows.Count, 1).End(xlUp).Row
Set arr(0) = New Collection
For f = lr To 2 Step -1
For k = 2 To f
Set arr(1) = New Collection
Set arr(2) = New Collection
arr(1).Add Workbooks(wb).Sheets(sh).Rows(f).Value
arr(2).Add Workbooks(wb).Sheets(sh).Rows(k).Value
If ср(arr(1).Item(1), arr(2).Item(1)) = True Then
fl = 0
For t = 1 To arr(0).Count
If ср(arr(1).Item(1), arr(0).Item(t)) = True Then fl = 1
Next t
If fl = 0 Then arr(0).Add ActiveSheet.Rows(f).Value
End If
Next k
Next f
str = 2 & ":" & lr
ActiveSheet.Rows(str).Clear
For f = 2 To arr(0).Count + 1
Workbooks(wb).Sheets(sh).Rows(f).Value = arr(0).Item(f - 1)
Next f
End Sub
Function ср(ar1, ar2) As Boolean
For t = 1 To 256
If ar1(1, t) <> ar2(1, t) Then Exit Function
Next t
ср = True
End Function

Sub unic()
Dim strMax As Long, strOk As Long, cOl1 As Long, cOl2 As Long
Dim rN As Range, letT1 As String, letT2 As String
cOl1 = 3
cOl2 = 4
letT1 = Mid(Columns(cOl1).Address, 2, InStr(1, Columns(cOl1).Address, ":") - 2)
letT2 = Mid(Columns(cOl2).Address, 2, InStr(1, Columns(cOl2).Address, ":") - 2)
strMax = Application.Max(Cells(Rows.Count, cOl1).End(xlUp).Row, Cells(Rows.Count, cOl2).End(xlUp).Row)
If strMax < 3 Then Exit Sub
For strOk = 2 To strMax - 1
    If Evaluate("=SUMPRODUCT((" & letT1 & strOk & "=" & letT1 & (strOk + 1) & ":" & letT1 & strMax & ")*(" & letT2 & strOk & "=" & letT2 & (strOk + 1) & ":" & letT2 & strMax & "))") = 0 Then
        If rN Is Nothing Then
            Set rN = Cells(strOk, cOl1)
        Else
            Set rN = Union(rN, Cells(strOk, cOl1))
        End If
    End If
Next strOk
Set rN = Union(rN, Cells(strMax, cOl1))
rN.EntireRow.Delete Shift:=xlUp
End Sub