Dim UserRange As Range
   Dim i As Integer, j As Integer
   Dim x As Variant
   Dim NN As Variant

   ' Ввод номеров   
   On Error GoTo Canceled
   Set UserRange = Application.InputBox _
      (Prompt:="Выделите диапазон с перечнем №№:", _
      Title:="SQL", _
      Type:= 8 ) ' <- код типа "ссылка на ячейки" как объект диапазона
   UserRange.Select
   
   
   ' Определение размера массива (всего номеров)
   x = UserRange.Value
	   
   If IsArray(x) Then
      For i =  1  To UBound(x,  1 )
         For j =  1  To UBound(x,  2 )

		   'Последовательные номера из перечня
            NN = x(i, j)

    ' Здесь будет БОЛЬШУЩЕЕ тело цикла  по обработке каждого запроса
    ' со своим номером NN
 
         Next j
      Next i
      
    Else
   ' Случай, когда обрабатывается только один номер
   ' (выделена только одна ячейка), т.е. она - не массив
            NN = x
            
     '?Здесь тоже придётся повторить тот же БОЛЬШОЙ объём кода,
     ' только из-за одного номера?..:(
     
    End If
    

Option Explicit

Dim NN As Variant

' Объекты новой книги Excel
Dim oBook, oSheet1, oSheet2 As Object


Public Sub NN_selection()

' Создание новой книги Excel и листов
Set oBook = Workbooks.Add
Set oSheet1 = oBook.Worksheets( 1 )
Set oSheet2 = oBook.Worksheets( 2 )
oSheet1.Name = "index_ADO"
oSheet2.Name = "temp_sheet"

' Сохранить эту новую книгу
 oBook.SaveAs "D:\ADO\ADO.xls"
 oBook.Close
 
Dim UserRange, myRng, iCel As Range
   
   ' Ввод номеров
   On Error GoTo Canceled
   Set UserRange = Application.InputBox _
      (Prompt:="Выделите диапазон(ы) с перечнем №№:", _
      Title:="SQL", _
      Type:= 8 )
   
   If UserRange Is Nothing Then
      MsgBox "Операция отменена"
   Else
      UserRange.Select
   End If

   'и перебор ячеек с данными
   Set myRng = UserRange

   For Each iCel In myRng
      
      NN = iCel.Value
      
      ' Подпрограмма обработки каждого номера
      Call NN_calculation
      
   Next
       
Canceled:
End Sub



Public Sub NN_calculation()

   Dim rsData As ADODB.Recordset
   Dim sPath, sConnect, sSQL As String
    

   ' Путь к базе данных
   sPath = _
      "C:\База данных" & _
      "\"
    
    ' Строка подключения
   sConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
            "Data Source=" & sPath & "База данных.mdb;" & _
            "Persist Security Info=False"
    
    ' SQL-запрос
   sSQL = "SELECT " & _
            "[Поле 1], [Поле 2], [Поле 3], [Поле 4]" & _
      "FROM [Таблица 1] " & _
      "WHERE [Поле 5] Like '%" & NN & "%' " & _
      "ORDER BY [Поле 1]"
           
   ' Извлечение данных с помощью ADO
   Set rsData = New ADODB.Recordset
   rsData.Open sSQL, sConnect, _
            adOpenForwardOnly, adLockReadOnly, adCmdText
   
   ' Удостовериться, что все данные получены
   If Not rsData.EOF Then
   
      ' Копирование полученных записей на лист 2   <- не переносится...:(
      oBook.Open
      oSheet2.Range("A1").CopyFromRecordset rsData
      
      
      ' Вызов процедуры для обработки данных на втором листе
      ' и перенос для группировки на первый
      Call NN_result
    
   
   Else
      Debug.Print "Данные не получены!" '<- хорошо бы в этом случае,
      'не прерывая макрос, записывать на первый лист между группами
      'обработанных данных извещение об этой ошибке с номером NN...:)
      
   End If
    
    ' Удалить объект Recordset, если он ещё существует
    If (rsData.State And ObjectStateEnum.adStateOpen) Then rsData.Close
    Set rsData = Nothing
    
   
End Sub

Public Sub NN_result

Dim r As Range       	'r - ячека(и) в текущей строке
Dim row As Integer   	'row - текущая строка
Dim r2max As Integer  	'rmax - кол-во строк

' работаем со вторым листом
oSheet2.Activate

r2max = oSheet2.UsedRange.Rows.Count

   ' Цикл по всем строкам второго листа
   For row =  1  To r2max

      ' - в колонке "A" нужно объединить содержимое E и F, как ранее по формуле 
      '=ТЕКСТ(E1;"000")&ТЕКСТ(F1;"000")    
      r.Cells("A:A").Value = WorksheetFunction.Text(r.Cells("E:E").Value, "000") & _
                           WorksheetFunction.Text(r.Cells("F:F").Value, "000")

      ' простановка в колонке "С" порядковых номеров
      r.Cells("C:C").Value = r
           
      ' для колонки "G" - если в начале ячейки нет слова "док", 
      ' добавить в начало "документ № ", иначе - пропустить
      ' =СЖПРОБЕЛЫ(ЕСЛИ(ЛЕВСИМВ(G1;3)<>"док";("документ № "&G1);(G1)))

      r.Cells("G:G").Value = Trim(IIf(WorksheetFunction.Left(r.Cells("G:G").Value, 3 ) <> "док", _
         ("документ № " & r), _
         r)))
              
      ' и т.д. и т.п...

   Next row
   
End Sub

Public Sub NN_result()

    Dim rng, rng_used, rng_0 As Range
    Dim row As Integer
    
    oSheet2.Range("A1:D1").EntireColumn.Insert
    
    Set rng_used = oSheet2.UsedRange
    Set rng_0 = oSheet2.Range(Cells( 1 ,  1 ), Cells(rng_used.Rows.Count,  4 ))
    Set rng = Union(rng_used, rng_0)


    For row =  1  To rng.Rows.Count

	...