Sub asd()
    Dim k&, i&, j&
    
    For i = Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1
        For j = i - 1 To 3 Step -1
            k = 0
            If UBound(Split(Cells(i, 1), " ")) = UBound(Split(Cells(j, 1), " ")) Then
                For Each word In Split(Cells(i, 1), " ")
                    If InStr(LCase(Cells(j, 1)), LCase(word)) > 0 Then
                        k = k + 1
                        If k = UBound(Split(Cells(i, 1), " ")) + 1 Then Rows(j).Delete
                    Else
                        Exit For
                    End If
                Next word
            End If
        Next j
    Next i
End Sub

Sub test()
Dim dic As Object, cnt
Dim arr$(), allarr(), i&, j&, z$, x&
Set dic = CreateObject("Scripting.Dictionary")
allarr = Range("a3:a" & Cells(Rows.Count, 1).End(xlUp).Row)
Range("a3:a" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
ReDim Preserve allarr(LBound(allarr) To UBound(allarr), 1 To 2)
For x = LBound(allarr) To UBound(allarr)
    allarr(x, 2) = allarr(x, 1)
    arr = Split(allarr(x, 1))
    For i = LBound(arr) To UBound(arr)
        For j = i + 1 To UBound(arr)
            If arr(i) > arr(j) Then z = arr(i): arr(i) = arr(j): arr(j) = z
        Next j
    Next i
    allarr(x, 1) = Join(arr)
    dic.Item(CStr(allarr(x, 1))) = allarr(x, 2)
Next x
Range("a3").Resize(dic.Count) = Application.Transpose(dic.items)
End Sub

Application.Transpose

Sub test111()
Dim dic As Object, cnt
Dim arr$(), allarr(), i&, j&, z$, x&
Set dic = CreateObject("Scripting.Dictionary")
allarr = Range("a3:a" & Cells(Rows.Count, 1).End(xlUp).Row)
Range("a3:a" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
ReDim Preserve allarr(LBound(allarr) To UBound(allarr), 1 To 2)
For x = LBound(allarr) To UBound(allarr)
    allarr(x, 2) = allarr(x, 1)
    arr = Split(allarr(x, 1))
    For i = LBound(arr) To UBound(arr)
        For j = i + 1 To UBound(arr)
            If arr(i) > arr(j) Then z = arr(i): arr(i) = arr(j): arr(j) = z
        Next j
    Next i
    allarr(x, 1) = Join(arr)
    dic.Item(CStr(allarr(x, 1))) = allarr(x, 2)
Next x
x = 0
ReDim arr(1 To dic.Count, 1 To 2)
For Each cnt In dic.items
    x = x + 1
    arr(x, 1) = cnt
Next cnt
Range("a3").Resize(dic.Count) = arr
End Sub

Sub test111()
Dim dic As New Collection, cnt
Dim arr$(), allarr(), i&, j&, z$, x&
allarr = Range("a3:a" & Cells(Rows.Count, 1).End(xlUp).Row)
Range("a3:a" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
ReDim Preserve allarr(LBound(allarr) To UBound(allarr), 1 To 2)
On Error Resume Next
For x = LBound(allarr) To UBound(allarr)
    allarr(x, 2) = allarr(x, 1)
    arr = Split(allarr(x, 1))
    For i = LBound(arr) To UBound(arr)
        For j = i + 1 To UBound(arr)
            If UCase(arr(i)) > UCase(arr(j)) Then z = arr(i): arr(i) = arr(j): arr(j) = z
        Next j
    Next i
    allarr(x, 1) = Join(arr)
    dic.Add allarr(x, 2), CStr(allarr(x, 1))
Next x
On Error GoTo 0
x = 0
ReDim arr(1 To dic.Count, 1 To 2)
For Each cnt In dic
    x = x + 1
    arr(x, 1) = cnt
Next cnt
Range("a3").Resize(dic.Count) = arr
End Sub