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

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

If InStr(1, arr2(j, 1), arr1(i, 0), vbTextCompare) > 0 Then

Public Function BinarySearch(List As Variant, target As Long) As Long
    Dim min As Long
    Dim max As Long
    Dim middle As Long
 
    NumSearches = 0
    min = 1
    max = NumItems
    Do While min <= max
        NumSearches = NumSearches + 1
        
        middle = (max + min) / 2
        If target = List(middle) Then
            BinarySearch = middle
            Exit Function
        ElseIf target < List(middle) Then
            max = middle - 1
        Else
            min = middle + 1
        End If
    Loop
    BinarySearch = 0'здесь можно поставить -1 кому как удобнее
End Function