Option Explicit

Sub ОдинаковыеСлова()
Dim iLastRow As Long
Dim i As Long
Dim j As Long
Dim k As Integer
Dim n As Long
Dim BeginRow As Long
Dim iDict As Object
Dim Строка As Variant
Dim ПодСтрока As Variant
Dim ЧислоСлов As Integer
    BeginRow = 2
iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
    For i = BeginRow To iLastRow
        Строка = Split(Trim(Cells(i, 1)), " ")
            ЧислоСлов = UBound(Строка) + 1
        For j = iLastRow To BeginRow + 1 Step -1
            ПодСтрока = Split(Trim(Cells(j, 1)), " ")
            If UBound(ПодСтрока) + 1 = ЧислоСлов Then
                n = 0
               
            Set iDict = CreateObject("scripting.dictionary")
               'заполняем словарь словами из массива Строка
               For k = 0 To UBound(Строка)
                    If Not iDict.Exists(Строка(k)) Then
                        iDict.Add Строка(k), 1
                    End If
               Next
               ' есть ли слова из подстроки в массиве Строка
               For k = 0 To UBound(ПодСтрока)
                    If iDict.Exists(ПодСтрока(k)) Then
                        n = n + 1
                    End If
                        If n = ЧислоСлов Then Cells(j, 1).EntireRow.Delete
               Next
            End If
       Next
    iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
    BeginRow = BeginRow + 1
        Next
End Sub