Sub CompareTwoStrings()
    Dim i As Long, j As Long, RangeToCompare As Range
    Dim sLen As Long, sLen1 As Long, sLen2 As Long
    
    On Error Resume Next
    Set RangeToCompare = Application.InputBox("Выделите два ОДИНАКОВЫХ диапазона удерживая клавишу Ctrl.", Environ("Username"), ActiveCell.Address(0, 0), , , , , 8)
    If RangeToCompare Is Nothing Then Exit Sub
    If RangeToCompare.Areas.Count <> 2 Then
        MsgBox "Выделите две ячейки или два одинаковых диапазона для сравнения удерживая клавишу Ctrl."
        Exit Sub
    End If
    If RangeToCompare.Areas(1).Cells.Count <> RangeToCompare.Areas(2).Cells.Count Then
        MsgBox "Выделите два ОДИНАКОВЫХ диапазона удерживая клавишу Ctrl."
        Exit Sub
    End If
    
    For i = 1 To RangeToCompare.Areas(1).Cells.Count
        
        Let sLen1 = Len(RangeToCompare.Areas(1).Cells(i).Text)
        Let sLen2 = Len(RangeToCompare.Areas(2).Cells(i).Text)
        RangeToCompare.Areas(1).Cells(i).Font.Color = vbBlack
        RangeToCompare.Areas(1).Cells(i).Font.TintAndShade = 0
        RangeToCompare.Areas(2).Cells(i).Font.Color = vbBlack
        RangeToCompare.Areas(2).Cells(i).Font.TintAndShade = 0
        
        If sLen1 = 0 Or sLen2 = 0 Then GoTo nextStep
        
        If sLen1 = sLen2 Then
            Let sLen = sLen1
            For j = 1 To sLen
                If AscW(Mid(RangeToCompare.Areas(1).Cells(i).Text, j, 1)) <> AscW(Mid(RangeToCompare.Areas(2).Cells(i).Text, j, 1)) Then
                    RangeToCompare.Areas(1).Cells(i).Characters(j, 1).Font.Color = vbRed
                    RangeToCompare.Areas(2).Cells(i).Characters(j, 1).Font.Color = vbRed
                End If
            Next j
        Else
            Let sLen = WorksheetFunction.Min(sLen1, sLen2)
            For j = 1 To sLen
                If AscW(Mid(RangeToCompare.Areas(1).Cells(i).Text, j, 1)) <> AscW(Mid(RangeToCompare.Areas(2).Cells(i).Text, j, 1)) Then
                    RangeToCompare.Areas(1).Cells(i).Characters(j, 1).Font.Color = vbRed
                    RangeToCompare.Areas(2).Cells(i).Characters(j, 1).Font.Color = vbRed
                End If
            Next j
            If sLen1 > sLen2 Then
                RangeToCompare.Areas(1).Cells(i).Characters(sLen2 + 1, sLen1 - sLen2).Font.Color = vbGreen
            Else
                RangeToCompare.Areas(2).Cells(i).Characters(sLen1 + 1, sLen2 - sLen1).Font.Color = vbGreen
            End If
        End If
nextStep:
    Next i
End Sub

'==============================================================================
'=================================Variant 2====================================
'==============================================================================

Sub CompareTwoStringsV2()
    Dim i As Long, j As Long, RangeToCompare As Range, newWsh As Worksheet, lastRowForNewSht As Long
    Dim sLen As Long, sLen1 As Long, sLen2 As Long, arrArray1(), arrArray2(), rngTmp1 As Range, rngTmp2 As Range
    
    On Error Resume Next
    Set RangeToCompare = Application.InputBox("Выделите два ОДИНАКОВЫХ диапазона удерживая клавишу Ctrl.", Environ("Username"), ActiveCell.Address(0, 0), , , , , 8)
    If RangeToCompare Is Nothing Then Exit Sub
    If RangeToCompare.Areas.Count <> 2 Then
        MsgBox "Выделите две ячейки или два одинаковых диапазона для сравнения удерживая клавишу Ctrl."
        Exit Sub
    End If
    If RangeToCompare.Areas(1).Cells.Count <> RangeToCompare.Areas(2).Cells.Count Then
        MsgBox "Выделите два ОДИНАКОВЫХ диапазона удерживая клавишу Ctrl."
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Set newWsh = ActiveWorkbook.Sheets.Add(After:=Worksheets(Worksheets.Count))
    With newWsh.Range("A1")
       .Value = "Сравнение двух текстовых строк"
       .Font.Bold = True
       .Font.Size = 21
    End With
    lastRowForNewSht = 3
    For i = 1 To RangeToCompare.Areas(1).Cells.Count
        
        Let sLen1 = Len(RangeToCompare.Areas(1).Cells(i).Text)
        Let sLen2 = Len(RangeToCompare.Areas(2).Cells(i).Text)
        
        If sLen1 = 0 Or sLen2 = 0 Then GoTo nextStep
        If sLen1 = sLen2 Then
            Let sLen = sLen1
            ReDim arrArray1(1 To 2, 1 To sLen)
            ReDim arrArray2(1 To 2, 1 To sLen)
            For j = 1 To sLen
                arrArray1(1, j) = AscW(Mid(RangeToCompare.Areas(1).Cells(i).Text, j, 1))
                arrArray1(2, j) = Mid(RangeToCompare.Areas(1).Cells(i).Text, j, 1)
                arrArray2(1, j) = AscW(Mid(RangeToCompare.Areas(2).Cells(i).Text, j, 1))
                arrArray2(2, j) = Mid(RangeToCompare.Areas(2).Cells(i).Text, j, 1)
            Next j
        Else
            Let sLen = WorksheetFunction.Max(sLen1, sLen2)
            ReDim arrArray1(1 To 2, 1 To sLen)
            ReDim arrArray2(1 To 2, 1 To sLen)
            For j = 1 To sLen
                arrArray1(1, j) = AscW(Mid(RangeToCompare.Areas(1).Cells(i).Text, j, 1))
                arrArray1(2, j) = Mid(RangeToCompare.Areas(1).Cells(i).Text, j, 1)
                arrArray2(1, j) = AscW(Mid(RangeToCompare.Areas(2).Cells(i).Text, j, 1))
                arrArray2(2, j) = Mid(RangeToCompare.Areas(2).Cells(i).Text, j, 1)
            Next j
        End If
        
        newWsh.Cells(lastRowForNewSht, 1) = RangeToCompare.Areas(1).Cells(i).Text
        newWsh.Cells(lastRowForNewSht, 1).Interior.Color = RGB(254, 255, 202)
        newWsh.Cells(lastRowForNewSht, 1).Offset(-1, 1).Resize(UBound(arrArray1, 1), UBound(arrArray1, 2)) = arrArray1
        Set rngTmp1 = Range(newWsh.Cells(lastRowForNewSht, 1).Offset(-1, 1), newWsh.Cells(lastRowForNewSht, 1).Offset(-1, 1).End(xlDown).End(xlToRight))
        With rngTmp1
            .HorizontalAlignment = xlRight
            .Borders.LineStyle = xlContinuous
            .Rows(2).Interior.Color = RGB(226, 239, 217)
        End With
        
        newWsh.Cells(lastRowForNewSht + 3, 1) = RangeToCompare.Areas(2).Cells(i).Text
        newWsh.Cells(lastRowForNewSht + 3, 1).Interior.Color = RGB(254, 255, 202)
        newWsh.Cells(lastRowForNewSht + 3, 1).Offset(-1, 1).Resize(UBound(arrArray2, 1), UBound(arrArray2, 2)) = arrArray2
        Set rngTmp2 = Range(newWsh.Cells(lastRowForNewSht + 3, 1).Offset(-1, 1), newWsh.Cells(lastRowForNewSht + 3, 1).Offset(-1, 1).End(xlDown).End(xlToRight))
        With rngTmp2
            .HorizontalAlignment = xlRight
            .Borders.LineStyle = xlContinuous
            .Rows(2).Interior.Color = RGB(226, 239, 217)
        End With
        
        For j = 1 To rngTmp1.Columns.Count
            If rngTmp1.Cells(1, j).Value <> rngTmp2.Cells(1, j).Value Then
                rngTmp1.Cells(2, j).Interior.Color = RGB(250, 208, 204)
                rngTmp2.Cells(2, j).Interior.Color = RGB(250, 208, 204)
            End If
        Next j
        
        lastRowForNewSht = newWsh.Cells(Rows.Count, 1).End(xlUp).Row + 3
        Erase arrArray1: Erase arrArray2
nextStep:
    Next i
End Sub

Option Explicit

Private Sub CheckBox1_Click()
    Call TextBox1_Change
End Sub

Private Sub TextBox1_Change()
    Dim i As Long, lngMach As Long, lngMach2 As Long, vbComparison As Long, Cell As Range
    
    If Len(Me.TextBox1) = 0 Then 'Пустой текстбокс
        Me.LabelInfo.Caption = ""
        Exit Sub
    End If
    
    If TypeName(Selection) <> "Range" Then 'НЕ диапазон выделен
        Me.LabelInfo.Caption = "Selection is not a Range"
        Exit Sub
    End If
    
    If Application.WorksheetFunction.CountA(Selection) = 0 Then 'Пустые ячейки
        Me.LabelInfo.Caption = "Selection is empty"
        Exit Sub
    End If
    
    If Me.CheckBox1 Then 'Учёт регистра
        vbComparison = vbBinaryCompare
    Else
        vbComparison = vbTextCompare
    End If
    
    Application.ScreenUpdating = False
    
    For Each Cell In Selection
        'Мешаные цвета в ячейке обнуляем
        If IsNull(Cell.Font.Color) Or Me.TextBox1.Text = "" Then
            Cell.Font.Color = 0
        End If
        
        i = 1
        lngMach = InStr(1, Cell.Text, Me.TextBox1.Text, vbComparison)
        
        Do While InStr(i, Cell.Text, Me.TextBox1.Text, vbComparison) > 0 And i <= Len(Cell)
            lngMach = InStr(i, Cell.Text, Me.TextBox1.Text, vbComparison)
            Cell.Characters(lngMach, Len(Me.TextBox1.Text)).Font.Color = vbRed
            i = lngMach + 1
            lngMach2 = lngMach2 + 1
        Loop
    Next Cell
    
    If lngMach2 = 0 Then
        Me.LabelInfo = "No match"
    Else
        Me.LabelInfo = "Найдено совпадений: " & lngMach2
    End If
    
End Sub

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    
    If TypeName(Selection) <> "Range" Then 'НЕ диапазон выделен
        Me.LabelInfo.Caption = "Selection is not a Range"
        Exit Sub
    End If
    
    If KeyCode = 8 And Shift = 2 Then
        Selection.Font.Color = 0
    End If
    If KeyCode = 46 And Shift = 2 Then
        Selection.Font.Color = 0
    End If
    If KeyCode = 46 And Len(Me.TextBox1.Text) = 1 Then
        Selection.Font.Color = 0
        
    End If
    If KeyCode = 8 And Len(Me.TextBox1.Text) = 1 Then
        Selection.Font.Color = 0
    End If
End Sub

Option Explicit
'http://lavka.pochaev.org.ua/ 'старый адресс(ЗАБЛОКИРОВАН!)
Const myLink As String = "https://lavka.pochaevlavra.org/"

Sub UpdatePrise()
    Dim xmlRequest As New MSXML2.XMLHTTP60, htmlDocument As New MSHTML.htmlDocument
    Dim CatalogBookList As MSHTML.IHTMLElement
    Dim CatalogBooks As MSHTML.IHTMLElementCollection
    Dim CatalogBook As MSHTML.IHTMLElement
    Dim CatalogBookID As Integer
    Dim NextHref As String, NextURL As String
    Dim t As Date
        Call A_RemoveOldPrice4
        t = Now
        xmlRequest.Open "GET", myLink, False
        'ЗАГОЛОВКИ пишутся между коммандами OPEN и SEND
        xmlRequest.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; Win64; x64; rv:89.0) Gecko/20100101 Firefox/89.0"
        xmlRequest.setRequestHeader "Accept", "text/html,application/xhtml+xml,application/xml;q=0.9,image/webp,image/apng,*/*;q=0.8"
        xmlRequest.setRequestHeader "Accept-Encoding", "gzip, deflate"
        xmlRequest.setRequestHeader "Content-Type", "text/html; charset=WINDOWS-1251"
        xmlRequest.send
        If xmlRequest.Status <> 200 Then
            MsgBox "Some error" & vbCrLf & "or no connection!" & _
            vbCrLf & "xmlRequest.Status is " & xmlRequest.Status
            Exit Sub
        End If
        Application.ScreenUpdating = False
'        Application.EnableEvents = False
        htmlDocument.body.innerHTML = xmlRequest.responseText
        Set xmlRequest = Nothing
        
        Set CatalogBookList = htmlDocument.getElementsByClassName("list-group")(1)
        Set CatalogBooks = CatalogBookList.getElementsByTagName("a")
        frmUpDatePoces.Show 0
'        Debug.Print CatalogBooks.Length
        For CatalogBookID = 0 To 62 Step 2 'CatalogBooks.Length - 1
            DoEvents
            frmUpDatePoces.Caption = "Progress of updating... " & Format(Now - t, "hh:mm:ss")
            frmUpDatePoces.Repaint
            frmUpDatePoces.lblGreen.Width = 200 / 100 * Int(CatalogBookID / 62 * 100)
            frmUpDatePoces.lblGreen.Caption = Int(CatalogBookID / 62 * 100) & "%"
            Set CatalogBook = CatalogBooks(CatalogBookID)
            If Not CatalogBook Is Nothing Then '===============================
                NextHref = CatalogBook.getAttribute("href")
                NextURL = myLink & Mid(NextHref, 8)
    '            Debug.Print NextURL 'CatalogBook.innerText,
                Call GetOneCatalog(NextURL)
            End If
        Next CatalogBookID
        Range("A2").CurrentRegion.WrapText = False
        Call PreparePriceList
        Unload frmUpDatePoces
'        Application.EnableEvents = True
        'MsgBox "Готово! " & Format(Now - t, "hh:mm:ss") ' & Format(Now - t, "ss")
End Sub