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

col = WorksheetFunction.Index(ar, 0, 1) 

col = WorksheetFunction.Index(ar, 0, 1) 

Sub KD7_ZaprosPoisk()
    a = Timer
    Application.ScreenUpdating = False
    'удаляем предыдущую базу если вдруг есть ==>
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists(ActiveWorkbook.FullName & ".mdb") Then fso.DeleteFile ActiveWorkbook.FullName & ".mdb", True
    'удаляем предыдущую базу если вдруг есть <==
    Dim dbConnectStr As String
    Dim Catalog As Object
    Dim cnt As ADODB.Connection
    Dim sCon$, rs As Object
    Dim sSQL$
    Set rs = CreateObject("ADODB.Recordset")
    Module5.sboboz 'сборочные шаблоны
    massoboz = Module5.oboz
    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=1qaz@WSX;Persist Security Info=True;User ID=User_for_macros_PDM;Initial Catalog=db_pdm_ScanKD;Data Source=RTVS-SQL05" 'Строка подключения
    conn.Open
    Set rst = New ADODB.Recordset
    rst.ActiveConnection = conn
    Ask = "SELECT [Oboznach],[izm],[Count_page], COUNT(*) as КоличествоЗаписей " _
    & "FROM [db_pdm_ScanKD].[dbo].[pdm_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 '%Э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 '%ПГ3' or [Oboznach] Like '%Э4' or [Oboznach] Like '%ТЭ4' or [Oboznach] Like '%ПИ' or [Oboznach] Like '%И2') " _
    & " GROUP BY [Oboznach],[izm],[Count_page]"
    rst.Open Ask, conn, adOpenStatic, adLockBatchOptimistic
    arr1 = rst.GetRows
    conn.Close
    arr1 = TransposeDim(arr1) 'переворачиваем массив
    qSort arr1, LBound(arr1), UBound(arr1), 0 'сортировка
    For i = LBound(arr1) To UBound(arr1)
        arr1(i, 3) = CStr(arr1(i, 3))
    Next
    'заполняем с сервера <==
    Dim col As Variant, N As Long
    col = WorksheetFunction.Index(arr1, 0, 1) 'выделяем 1й столбец массива
    For i = LBound(arr2) To UBound(arr2)
        m = arr2(i, 1)
        m1 = m + "СБ"
        N = WorksheetFunction.Match(m1, col, 1)
        If col(N, 1) = m1 Then
            arr2(i, 2) = arr1(N, 0)
        Else
            N = WorksheetFunction.Match(m, col, 1)
            If col(N, 1) = m Then
                arr2(i, 2) = arr1(N, 0)
            Else
                m = Trim$(m)
                If InStr(1, m, "-") > 0 Then
                    m = Left(m, InStr(1, m, "-") - 1)
                End If
                m1 = m + "СБ"
                N = WorksheetFunction.Match(m1, col, 1)
                If col(N, 1) = m1 Then
                    arr2(i, 2) = arr1(N, 0)
                Else
                    N = WorksheetFunction.Match(m, col, 1)
                    If col(N, 1) = m Then
                        arr2(i, 2) = arr1(N, 0)
                    Else
                        arr2(i, 2) = Empty
                    End If
                End If
            End If
        End If
    Next i
    Stop
    ActiveSheet.Cells(2, ncolumn).Resize(UBound(arr2), UBound(arr2, 2)) = arr2
    Application.ScreenUpdating = True
    MsgBox Timer - a
End Sub

col = WorksheetFunction.Index(arr1, 0, 1) 'выделяем 1й столбец массива