Dim cell As Range
    Range("A2").Value = Replace(Range("A2").Value, Chr(160), " ")
    Range("A2").Value = Replace(Range("A2").Value, Chr(9), " ")
    Range("A2").Value = Application.WorksheetFunction.Trim(Range("A2").Value)
             
   excelWorksheet.Range("F2").Select
   For Each cell In Selection
          cells(2, 1).Value = Replace(cells(2, 6).Value, vbCrLf, vbCr) ' Удалить пустые строки
          'cells(2, 1).Value = Replace(cells(2, 6).Value, Chr(10), "")  ' ?
   Next cell

Option Explicit 
Sub CompareText_Main()
    Dim rng1 As range, rng2 As range
    Set rng1 = GetRange("Основной диапазон")
    Set rng2 = GetRange("Диапазон для сравнения")
     
    If rng1.Rows.Count <> rng2.Rows.Count Then
        MsgBox "Диапазоны должны быть равны", vbCritical, "***"
        Exit Sub
    End If
     
    rng1.Font.Color = vbBlack
    rng2.Font.Color = vbRed
     
    Call CompareRanges(rng1, rng2)
End Sub
 
Private Sub CompareRanges(rng1 As range, rng2 As range)
    Dim x As Long
    For x = 1 To rng1.Rows.Count
         
        Dim where As String, find As String
        where = rng2.Cells(x).Value
        find = RealFind(rng1.Cells(x).Value, where)
         
        If find <> Empty Then
            Dim arrSpl As Variant
            arrSpl = Split(find, ";")
             
            Dim i As Long
            For i = LBound(arrSpl) To UBound(arrSpl) - 1
                 
                Dim word As String: word = arrSpl(i)
                Dim q As Integer, step As Integer
                step = IIf(Len(word) = 1, 1, Len(word))
                For q = 1 To Len(where) Step step
                    Dim inString As Long
                    inString = InStr(q, LCase(where), LCase(word), vbTextCompare)
                     
                    If inString > 0 Then
                        rng2.Cells(x).Characters(inString, step).Font.Color = vbBlack
                        q = inString + step
                    End If
                Next q
            Next i
        End If
    Next x
End Sub
 
Function RealFind(ByVal what As String, ByVal where As String) As String
    what = CleanString(what)
     
    Dim arrWhat As Variant
    arrWhat = Split(what, " ")
 
    Dim n As Long
    For n = LBound(arrWhat) To UBound(arrWhat)
        Dim inString As Long: inString = 0
        inString = InStr(1, LCase(where), LCase(arrWhat(n)), vbTextCompare)
         
        Dim result As String
        If inString > 0 Then result = result & arrWhat(n) & ";"
    Next n
     
    RealFind = result
End Function
 
Private Function CleanString(what As String) As String
    Dim RE As Object
    Set RE = CreateObject("VBScript.RegExp")
    RE.Global = True
    RE.Pattern = "[^\dА-Яа-яA-Za-z,()=]"
     
    CleanString = Application.Trim(RE.Replace(what, " "))
End Function
 
Private Function GetRange(header As String) As range
    Set GetRange = Application.InputBox(header, "Выделите диапазон", , , , , , 8)
End Function