Ускорить работу макроса

Sub test()
    Dim arr1()
    Application.ScreenUpdating = False
    'range и массив рабочей книги
    ncolumn = Rows(1).Find(What:="Обозначение", LookIn:=xlValues, LookAt:=xlWhole).Column
    Columns(ncolumn + 1).Insert 'вставляем столбец справа
    Cells(1, ncolumn + 1).Value = "Карточки" 'вставляем заголовок столбца
    m = ActiveSheet.Cells(Rows.Count, ncolumn).End(xlUp).Row
    Set rn = ActiveSheet.Cells(2, ncolumn).Resize(m, 2)
    arr2 = rn.Value
    Set conn = New ADODB.Connection     'Создание соединения
    conn.ConnectionString = "Provider=SQLOLEDB.1;Password=132132;Persist Security Info=True;User ID=User;Initial Catalog=dbScanKD;Data Source=SQL05" 'Строка подключения
    conn.Open   'Открытие соединения
    Set rst = New ADODB.Recordset ' Создание объекта Recordset.
    rst.ActiveConnection = conn ' Подключение этого объекта к ранее открытому каналу связи.
    Ask = "SELECT DISTINCT [Oboznach] FROM [dbScanKD].[dbo].[vwScanKD] Where Not ([Oboznach] Like '%СБ'or [Oboznach] Like '%ТУ' or [Oboznach] Like '%ИМ' or [Oboznach] Like '%ДИ' or [Oboznach] Like '%РР' or [Oboznach] Like '%РИ' or [Oboznach] Like '%УД' or [Oboznach] Like '%ЛУ' or [Oboznach] Like '%ТБ' or [Oboznach] Like '%Э3' or [Oboznach] Like '%ПЭ3' or [Oboznach] Like '%Д7' or [Oboznach] Like '%К3' or [Oboznach] Like '%Д4' or [Oboznach] Like '%ДП' or [Oboznach] Like '%РИ' or [Oboznach] Like '%ПГ3' or [Oboznach] Like '%ПГ4' or [Oboznach] Like '%Г4' or [Oboznach] Like '%Э4' or [Oboznach] Like '%ТЭ4' or [Oboznach] Like '%ПИ' or [Oboznach] Like '%И2')"
    rst.Open Ask, conn, adOpenStatic, adLockBatchOptimistic  ' выполняем запрос.
    arr1 = rst.GetRows 'закидываем в массив
    conn.Close 'закрываем соединение
    arr1 = TransposeDim(arr1) 'переворачиваем массив из строк в столбец через функцию TransposeDim с сайта майкрософт
    For i = LBound(arr1) To UBound(arr1)
        For j = LBound(arr2) To UBound(arr2)
            If Len(arr2(j, 1)) > 0 Then
                If InStr(1, arr1(i, 0), "СБ") > 0 Then
                    If InStr(arr2(j, 1), "-") > 0 Then
                        m = Left(arr2(j, 1), InStr(1, arr2(j, 1), "-") - 1) + "СБ"
                        If InStr(1, arr2(j, 1) + "СБ", arr1(i, 0), vbTextCompare) > 0 Then
                            If CInt(arr1(i, 2)) = CInt(arr1(i, 3)) Then 'cравниваем числовые значения
                                arr2(j, 2) = arr1(i, 0)
                            Else
                                arr2(j, 2) = "нет страниц"
                            End If
                        Else
                            If InStr(1, m, arr1(i, 0), vbTextCompare) > 0 Then
                                If CInt(arr1(i, 2)) = CInt(arr1(i, 3)) Then 'cравниваем числовые значения
                                    arr2(j, 2) = arr1(i, 0)
                                Else
                                    arr2(j, 2) = "нет страниц"
                                End If
                            End If
                        End If
                    Else
                        If InStr(1, arr2(j, 1) + "СБ", arr1(i, 0), vbTextCompare) > 0 Then
                            If CInt(arr1(i, 2)) = CInt(arr1(i, 3)) Then 'cравниваем числовые значения
                                arr2(j, 2) = arr1(i, 0)
                            Else
                                arr2(j, 2) = "нет страниц"
                            End If
                        End If
                    End If
                Else
                    If arr2(j, 2) = Empty Then
                        If InStr(1, arr2(j, 1), arr1(i, 0), vbTextCompare) > 0 Then
                            For k = 1 To UBound(massoboz)
                                If InStr(arr2(j, 1), massoboz(k, 1)) > 0 Then
                                    arr2(j, 2) = "нет сборочного"
                                    Exit For
                                Else
                                    If CInt(arr1(i, 2)) = CInt(arr1(i, 3)) Then 'cравниваем числовые значения
                                        arr2(j, 2) = arr1(i, 0)
                                    Else
                                        arr2(j, 2) = "нет страниц"
                                    End If
                                End If
                            Next k
                        End If
                    End If
                End If
            End If
        Next j
    Next i
    ActiveSheet.Cells(2, ncolumn).Resize(UBound(arr2), UBound(arr2, 2)) = arr2'вываливаем на лист
    Application.ScreenUpdating = True
End Sub

Option Explicit
'
'Код для Лист1
'
Dim cl As New Collection
 
Private Sub CommandButton2_Click()
    '
    'Поиск приближенных совпадений
    '
    Dim i&, j&, ii&, jj&, s$, try&, v, CurR&, CurC&
    Dim yes&
    On Error Resume Next 'Включаем игнор ошибок
    Set cl = New Collection 'Инициализируем коллекцию
    CurR = 14 'Сюда будем писать результаты начиная с 14-й строки
    
    With Sheets("лист3") 'Заполняем коллекцию для искомых данных
        ii = .Cells(Rows.Count, 1).End(xlUp).Row 'Определение последней заполненной строки
        jj = .Cells(1, Columns.Count).End(xlToLeft).Column 'Определение последнего столбца
        For i = 1 To ii: For j = 1 To jj
            For try = 3 To 100
                s = Space(try): RSet s = .Cells(i, j)
                Err.Clear: cl.Add .Cells(i, j), s
                If Err = 0 Then Exit For 'Выход если ключ не занят
            Next
        Next j, i
    End With
    
    With Sheets("лист2")
        ii = .Cells(Rows.Count, 1).End(xlUp).Row 'Определение последней заполненной строки
        jj = .Cells(1, Columns.Count).End(xlToLeft).Column 'Определение последнего столбца
        For i = 1 To ii: For j = 1 To jj
            yes = 0
            For try = 3 To 100
                s = Space(try): RSet s = .Cells(i, j)
                Err.Clear
                v = cl(s)
                If Err Then Exit For 'Эта ошибка возникает если совпадений более нет
                yes = 1
                With Sheets("лист1")
                    CurC = (try - 3) * 3
                    .Cells(CurR, 1 + CurC).Value = s
                    .Cells(CurR, 2 + CurC).Value = v
                End With
            Next
            CurR = CurR + yes
        Next j, i
    End With
    
 
End Sub
 
Sub RWord(Range As Range)
    '
    'Случайное слово с точкой и цифрой
    '
    Dim i&, j&, s$
    s = Space(20)
    For i = 1 To 3
        Mid$(s, i, 1) = Chr(97 + Fix(Rnd * 26))
    Next: Mid$(s, i, 1) = "."
    For i = i + 1 To i + 3 + Fix(Rnd * 3)
        Mid$(s, i, 1) = Fix(Rnd * 10)
    Next
    Range.Value = RTrim$(s)
End Sub
 
Private Sub CommandButton1_Click()
    '
    'Создание двух таблиц со случайными значениями
    '
    Dim i&, j&
    With Sheets("лист2")
        .Cells.ClearContents
        For i = 1 To 100: For j = 1 To 10
            RWord .Cells(i, j)
        Next j, i
    End With
    With Sheets("лист3")
        .Cells.ClearContents
        For i = 1 To 200: For j = 1 To 20
            RWord .Cells(i, j)
        Next j, i
    End With
End Sub
 
 
Private Sub CommandButton3_Click()
    With Sheets("лист1")
        .Rows("14:" & .Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
    End With
End Sub