Удаление строк по сложному условию с посимвольным сравнением значений ячеек

Option Explicit
Option Compare Text
Sub Очистка_словаря()
    Dim EndRow&, i&, j&, k&, Ostavit&, MinLen%, n%, Ar, Root$
    Dim Uslovie As Boolean, Usl2 As Boolean, Usl3 As Boolean
    ' Окончания оставляемых английских слов в порядке убывания приоритета.
    '                             0   1    2
    Dim Postfix: Postfix = Array("e", "y", "")
    ' 2-е в массиве (3-е по счету) окончание - пустое, то есть используем голый корень
    EndRow = ActiveSheet.Cells(1, 1).End(xlDown).row
    Ar = ActiveSheet.Range("A1:B" & EndRow).Value ' Массив значений из ячеек
    i = EndRow
    ActiveSheet.Cells.Columns(1).Interior.Pattern = xlNone
    Do
      Uslovie = False
      If Not IsEmpty(Ar(i, 2)) Then
        k = 0
        MinLen = Len(Ar(i, 1))
        For j = i - 1 To 1 Step -1
            If Ar(i, 2) = Ar(j, 2) Then
               k = j
               If MinLen > Len(Ar(j, 1)) Then MinLen = Len(Ar(j, 1))
            Else
               Exit For
            End If
        Next j
        If k > 0 Then
            Do
                Usl3 = False
                MinLen = Len(Ar(i, 1))
                For j = i - 1 To k Step -1
                    If MinLen > Len(Ar(j, 1)) Then MinLen = Len(Ar(j, 1))
                Next j
                For n = MinLen To 2 Step -1 ' Минимальная длина корня = 2 символа
                    Usl2 = True
                    Root = Left(Ar(i, 1), n)
                    For j = i - 1 To k Step -1
                        If Root <> Left(Ar(j, 1), n) Then Usl2 = False: Exit For
                    Next j
                    If Usl2 Then Exit For
                Next n
                n = Len(Root)
                For j = i - 1 To k Step -1
                    If Root <> Left(Ar(j, 1), n) Then k = j + 1: Usl3 = True: Exit For
                Next j
            Loop While Usl3 ' Этот цикл нужен для определения дипазона первого корня в диапазоне  одинаковых переводов
            If Usl2 Then
                For n = 0 To UBound(Postfix, 1)
                    Usl2 = False
                    For j = i To k Step -1
                        If Root & Postfix(n) = Ar(j, 1) Then Usl2 = True: Ostavit = j: Exit For
                    Next j
                    If Usl2 Then Uslovie = True: Exit For
                Next n
            End If
        End If
        If Uslovie Then
            For j = i To k Step -1
                If j <> Ostavit Then
                    Cells.Rows(j).Delete shift:=xlUp
                   ' Cells(j, 1).Interior.Color = vbYellow
                End If
            Next j
        End If
      End If
      If Uslovie Then i = k - 1 Else i = i - 1
    Loop While i > 0
End Sub