Option Compare Text
Option Explicit
  Dim xlApp As Excel.Application
  Dim xlBook As Excel.Workbook
  Dim xlSheet As Excel.Worksheet
  Dim obExcel As Object
  Dim obWindow As Object  'окно документа

'Печать/выгрузка манифеста и акта
Private Sub ManifAkt_9()

'Открываем шаблон Excel-файла
  StartExcelEasy "Shabl"
  
'Отключаем вывод оповещаний
  DoCmd.SetWarnings False

'Вставка данных для листа-манифеста
  DoCmd.RunSQL "INSERT INTO [ManifTBL] (  бла-бла-бла )" & _
  "SELECT Выгрузка.бла-бла-бла " & _
  "FROM [Выгрузка];"
  
 'Включаем оповещания
  DoCmd.SetWarnings True
  
  CounterManif 'вызываем функцию счетчика

  Dim sNWind1 As String       ' For conn1 (ManifTBL-таблица)
  Dim sNWind2 As String       ' For conn2 (запрос)
  Dim sNWind3 As String       ' For conn3 (AktTBL, таблица)
  Dim sNWind4 As String       ' For conn4 (AktZapros, Запрос)
  
  Dim conn1 As New ADODB.Connection
  Dim conn2 As New ADODB.Connection
  Dim conn3 As New ADODB.Connection
  Dim conn4 As New ADODB.Connection
  
  Dim rs1 As ADODB.Recordset  
  Dim rs2 As ADODB.Recordset  
  Dim rs3 As ADODB.Recordset
  Dim rs4 As ADODB.Recordset
     
  sNWind1 = "c:\база.mdb"
  conn1.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sNWind1 & ";"
  conn1.CursorLocation = adUseClient
   
  sNWind2 = "c:\база.mdb"
  conn2.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sNWind2 & ";"
  conn2.CursorLocation = adUseClient
   
  sNWind3 = "c:\база.mdb"
  conn3.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sNWind3 & ";"
  conn3.CursorLocation = adUseClient
  
  sNWind4 = "c:\база.mdb"
  conn4.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sNWind4 & ";"
  conn4.CursorLocation = adUseClient
   
  Set rs1 = conn1.Execute("ManifTBL", , adCmdTable)                  ' Таблица
  Set rs2 = conn2.Execute("ManifZapros", , adCmdTable)                 ' Запрос
  Set rs3 = conn3.Execute("AktTBL", , adCmdTable)       ' Таблица
  Set rs4 = conn4.Execute("AktZapros", , adCmdTable) ' Запрос
    
'Вставка количества пустых строк в эксель, равную количеству строк в таблице ManifTBL
'- Делаем лист "манифест" активным
  xlApp.Sheets("манифест").Select
  xlApp.Sheets("манифест").Range("9:9").Select
  xlApp.Sheets("манифест").Range("B9").Activate
  
  Dim i As Integer
' - Вставляем нужное кол-во строк в таблице-шаблоне. // Здесь выполняется шикарно.
  For i = 0 To rs1.RecordCount - 3
  xlApp.Selection.Insert Shift:=xlDown
  Next i
   
'Экспорт из МСА-таблицы ManifTBL в Эксель, лист манифест // Здесь всё выполняется шикарно.
  xlApp.Sheets("манифест").Range("rangeManif").CopyFromRecordset rs1
  xlApp.Sheets("манифест").Range("date").value = Now()
  xlApp.Sheets("манифест").Range("Доставил_Маниф").value = rs2![Доставил_Маниф] ' ИЗ ЗАПРОСА!!!
  xlApp.Sheets("манифест").Range("WhoPrint").value = CurrentUser()
  xlApp.Sheets("манифест").Range("TimePrint").value = Time
  xlApp.Sheets("манифест").Range("A7").Select
  xlApp.Selection.Sort Key1:=xlApp.Sheets("манифест").Range("A7"), Order1:=xlAscending, Header:=xlGuess, _
  OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

' Close 2 recordsets
  rs1.Close
  rs2.Close
  conn1.Close
  conn2.Close
  Set rs1 = Nothing
  Set rs2 = Nothing
     
' ============== Выгрузка Листа Акт ============================

'Отключаем вывод оповещаний
  DoCmd.SetWarnings False
     
'Вставляем данные для листа Акт
  DoCmd.RunSQL "INSERT INTO [AktTBL] ( бла-бла-бла )" & _
  "SELECT Выгрузка.бла-бла-бла " & _
  "FROM [Выгрузка];"

'Считаем и вставляем нумерацию строк в таблице AktTBL
  CounterAkt

'Проверяем, является ли отправитель ИМ и вставляем значения в ОценочнаяСтоимость и НаложенныйПлатеж
' - Является ИМ (ОцСт=ОцСт, НалПлат=ОцСт):
  DoCmd.OpenQuery "_AktPeredachiUpdIM_Sum"
' - НЕ является ИМ (ОцСт=3000, НалПлат=0)
  DoCmd.OpenQuery "_AktPeredachiUpdNotIM_Sum"

'Включаем оповещания
  DoCmd.SetWarnings True

' ===== ЭКСПОРТ В ЭКСЕЛЬ ===== !!!
  xlApp.Sheets("акт").Activate
  xlApp.Sheets("акт").Range("10:10").Select
  xlApp.Sheets("акт").Range("B10").Activate

'Вставляем нужное кол-во строк в таблицу-шаблон ' // ЗДЕСЬ НЕ РАБОТАЕТ, ВЫШЕ НА 1-м ЛИСТЕ РАБОТАЕТ.
  Dim j As Integer
  For j = 0 To rs4.RecordCount - 3
  xlApp.Selection.Insert Shift:=xlDown
  Next j
   
'Экспорт из МСА запроса AktZapros в Эксель, лист акт

  xlApp.Sheets("акт").Range("rangeAkt").CopyFromRecordset rs4 ' // ЗДЕСЬ НЕ РАБОТАЕТ
  
'Вставляем дату в шапку
  'xlApp.Sheets("акт").Range("date").value = Now() ' // И ТАК РАБОТАЕТ !!!
  xlSheet.Range("date").value = Now() ' // ЗДЕСЬ РАБОТАЕТ !!!
  xlApp.Sheets("акт").Range("WhoPrint").value = CurrentUser() ' // ЗДЕСЬ РАБОТАЕТ !!!
  xlApp.Sheets("акт").Range("TimePrint").value = Time ' // ЗДЕСЬ РАБОТАЕТ !!!
  
'Close the connection. Закрываем подключения, ресетим рекордсеты
 
  rs3.Close
  rs4.Close
  conn3.Close
  conn4.Close
  
  Set rs3 = Nothing
  Set rs4 = Nothing
  Set xlSheet = Nothing
  Set xlBook = Nothing
  Set xlApp = Nothing
   
End Sub