Option Explicit  ': Option Compare Text
Public Declare Function timeGetTime Lib "winmm.dll" () As Long
Public Const kk As Long = 1  ' номер столбца описание товара
Public Const kk1 As Long = 3 'номер столбца БТ2  
Public Const nn1 As String = "БТема.xlsx" 'Название книги
Sub Dk_1()
Dim a(), b(), ii&, i&, x&, d&, z&, j&, c(), t&
Dim vb As Worksheet, s$, ss$, sa$, vn As Worksheet
t = timeGetTime
With ThisWorkbook.ActiveSheet
         .Activate 'Select
       x = .Cells(.Rows.Count, kk).End(xlUp).Row
       a = Range(.Cells(2, kk), .Cells(x, kk))
End With
Set vb = ActiveSheet  ''Добавлять сюда в конец:  "(", ")", "s" )
c = Array(" ", ",", ".", "-", "_", "+", "*", "\", "/", "[", "]", "{", "}", "'", ";", ":", "=", """", "(", ")")
With CreateObject("Scripting.Dictionary"): .CompareMode = 1
    For i = 0 To UBound(c)
       .Item(c(i)) = .Item(c(i)) + 1
    Next
For ii = 1 To UBound(a)
       If 0 = (ii Mod 1000) Then Application.StatusBar = "Подготовка строк  " & ii
s = LCase(Trim(a(ii, 1)))
ss = ""
For i = 1 To Len(s)
      sa = Mid(s, i, 1)
If Not (.Exists(sa)) Then ss = ss & sa
Next i
If IsNumeric(Mid(ss, 1, 1)) Then ss = Mid(ss, 2, Len(ss))
a(ii, 1) = ss
Next ii
Columns(kk).ClearContents
Cells(2, kk).Resize(x - 1, 1) = a
Windows(nn1).Activate
Set vn = ActiveSheet
With vn
         .Activate
       z = .Cells(.Rows.Count, 1).End(xlUp).Row
       d = .Cells(.Rows.Count, 2).End(xlUp).Row
       j = .Cells(.Rows.Count, 3).End(xlUp).Row
       If z < d Then z = d
       If z < j Then z = j
End With
b = Range(Cells(2, 1), Cells(z, 3))
For ii = 1 To UBound(b)
    If 0 = (ii Mod 5000) Then Application.StatusBar = "Готовим строки  " & ii
s = LCase(Trim(b(ii, 1)))
ss = ""
For i = 1 To Len(s)
    sa = Mid(s, i, 1)
If Not (.Exists(sa)) Then ss = ss & sa
Next i
b(ii, 1) = ss
Next ii
Columns("a:a").ClearContents
[a2].Resize(z - 1, 1) = b ''''''''''''''''''
Columns("a:a").NumberFormat = "@"
.RemoveAll
End With
vb.Activate: d = 0
If Len(Cells(1, 100)) Then
j = Cells(1, 100)
Else
j = 1
End If
For i = j To UBound(a) 'x
     If 0 = (i Mod 50) Then
     Cells(1, 100) = i
      Application.StatusBar = "Обработано строк " & i & " найдено " & d
     End If
'сохранение каждых 5000 строк
'  If 0 = (i Mod 5000) Then    ThisWorkbook.Save
        
    For ii = 1 To UBound(b)  'z
      If Len(Cells(i + 1, kk1)) <> 0 Or Len(Cells(i + 1, kk1 + 1)) <> 0 Then Exit For
      If InStr(1, a(i, 1), b(ii, 1), vbBinaryCompare) Then
       Cells(i + 1, kk1) = b(ii, 2)
       Cells(i + 1, kk1 + 1) = b(ii, 3): d = d + 1
      Exit For
      End If
Next: Next
Application.StatusBar = False
Cells(1, kk + 1) = timeGetTime - t & "  ìèëèñåê"
Cells(1, kk + 2) = d & " íàéäåíî"
End Sub
Sub cilki()
       If Application.ReferenceStyle = xlR1C1 Then
           Application.ReferenceStyle = xlA1
          Else
          Application.ReferenceStyle = xlR1C1
       End If
End Sub

For i = j To UBound(a) 'x
     If 0 = (i Mod 50) Then
     Cells(1, 100) = i
     Application.StatusBar = "Обработано строк " & i & " найдено " & d
     End If
'сохранение каждых 5000 строк
'  If 0 = (i Mod 5000) Then    ThisWorkbook.Save
          
     For ii = 1 To UBound(b)  'z
     If Len(Cells(i + 1, kk1)) <> 0 Or Len(Cells(i + 1, kk1 + 1)) <> 0 Then Exit For
     If InStr(1, a(i, 1), b(ii, 1), vbBinaryCompare) Then
     Cells(i + 1, kk1) = b(ii, 2)
     Cells(i + 1, kk1 + 1) = b(ii, 3): d = d + 1
     Exit For
     End If