Private Sub knExpExES_ogr_Click()

Dim app As Excel.Application
Dim strDOT As String
Dim MyTable As DAO.Recordset
Dim i As Integer

Me.Refresh

'Открываем эксель, в нем книгу на основе шаблона
Set app = New Excel.Application
app.Visible = True
strDOT = CurrentProject.Path & "\" & "Отчет по графику ограничения теплоснабжения.xlt"
app.Workbooks.Add strDOT

'Создаем набор записей (почему в одну строку: в несколько строк выдает ошибку на WHERE)
Set MyTable = CurrentDb.OpenRecordset("SELECT тРеестр.№_дог, тРеестр.Абонент, тРеестр.Street, тРеестр.N_dom, тРеестр.Tk, тРеестр.Оплата, тРеестр.Долг, тРеестр.Дата_откл_план, тРеестр.Naimen, тРеестр.Otchet, тРеестр.№_графика, тРеестр.Тип_графика FROM тРеестр INNER JOIN tDataExport ON (tDataExport.TipGraf = тРеестр.Тип_графика) AND (тРеестр.Дата_добавления = tDataExport.DataExport) WHERE (((тРеестр.№_графика) Is Not Null) And ((тРеестр.Тип_графика) Is Not Null))ORDER BY тРеестр.№_дог, тРеестр.Street, тРеестр.N_dom, тРеестр.№_графика, тРеестр.Тип_графика;")

i = 9

'Цикл по нашему набору записей
Do While Not MyTable.EOF
'Начиная с 9-ой строки вставляем в соотв-ие столбцы соотв-ие значения из нашего набора записей
        app.Parent.Range("b" & i).Select
        app.Parent.ActiveCell.FormulaR1C1 = CStr(Nz(MyTable.Fields("№_дог"), ""))
        app.Parent.Range("c" & i).Select
        app.Parent.ActiveCell.FormulaR1C1 = CStr(Nz(MyTable.Fields("Абонент"), ""))
        app.Parent.Range("d" & i).Select
        app.Parent.ActiveCell.FormulaR1C1 = CStr(Nz(MyTable.Fields("Street"), ""))
        app.Parent.Range("e" & i).Select
        app.Parent.ActiveCell.FormulaR1C1 = CStr(Nz(MyTable.Fields("N_dom"), ""))
        app.Parent.Range("f" & i).Select
        app.Parent.ActiveCell.FormulaR1C1 = CStr(Nz(MyTable.Fields("Tk"), ""))
        app.Parent.Range("g" & i).Select
        app.Parent.ActiveCell.FormulaR1C1 = CStr(Nz(MyTable.Fields("Оплата"), ""))
        app.Parent.Range("h" & i).Select
        app.Parent.ActiveCell.FormulaR1C1 = CStr(Nz(MyTable.Fields("Долг"), ""))
        app.Parent.Range("i" & i).Select
        app.Parent.ActiveCell.FormulaR1C1 = CStr(Nz(MyTable.Fields("Дата_откл_план"), ""))
        app.Parent.Range("j" & i).Select
        app.Parent.ActiveCell.FormulaR1C1 = CStr(Nz(MyTable.Fields("Naimen"), ""))
        app.Parent.Range("k" & i).Select
        app.Parent.ActiveCell.FormulaR1C1 = CStr(Nz(MyTable.Fields("Otchet"), ""))
        
    i = i + 1
    MyTable.MoveNext

Loop
MyTable.Close

End Sub

Private Sub Testexcel_Click()
' Проба нового экспорта

Dim XL As Object
Dim XLT As Object
Dim newrow As Object
Dim rsd As ADODB.Recordset
Dim strSQL As String
Set rsd = New ADODB.Recordset

Dim app As Excel.Application
Dim strDOT As String
'Dim MyTable As DAO.Recordset
'Dim i As Integer

'запрос к базе данных
'strSQL = "SELECT тРеестр.№_дог, тРеестр.Абонент, тРеестр.Street, тРеестр.N_dom," & _
'    "тРеестр.Tk, тРеестр.Оплата, тРеестр.Долг, тРеестр.Дата_откл_план, тРеестр.Naimen, " & _
'    "тРеестр.Otchet, тРеестр.№_графика, тРеестр.Тип_графика FROM тРеестр" & _
'    "INNER JOIN tDataExport ON (tDataExport.TipGraf = тРеестр.Тип_графика)" & _
'    "AND (тРеестр.Дата_добавления = tDataExport.DataExport)" & _
'    "WHERE (((тРеестр.№_графика) Is Not Null) And ((тРеестр.Тип_графика) Is Not Null))" & _
'    "ORDER BY тРеестр.№_дог, тРеестр.Street, тРеестр.N_dom, тРеестр.№_графика, тРеестр.Тип_графика;"
' Такая запись запроса выдаёт ошибку, поэтому ниже то же, но в одну строку

strSQL = "SELECT тРеестр.№_дог, тРеестр.Абонент, тРеестр.Street, тРеестр.N_dom, тРеестр.Tk, тРеестр.Оплата, тРеестр.Долг, тРеестр.Дата_откл_план, тРеестр.Naimen, тРеестр.Otchet, тРеестр.№_графика, тРеестр.Тип_графика FROM тРеестр INNER JOIN tDataExport ON (tDataExport.TipGraf = тРеестр.Тип_графика) AND (тРеестр.Дата_добавления = tDataExport.DataExport)WHERE (((тРеестр.№_графика) Is Not Null) And ((тРеестр.Тип_графика) Is Not Null))ORDER BY тРеестр.№_дог, тРеестр.Street, тРеестр.N_dom, тРеестр.№_графика, тРеестр.Тип_графика;"

rsd.Open strSQL, CurrentProject.Connection

'Set app = New Excel.Application
'app.Visible = True
strDOT = CurrentProject.Path & "\" & "Отчет по графику ограничения теплоснабжения.xlt"
'app.Workbooks.Add strDOT

'для примера показываю, как можно сразу загружать шаблон без выбора
'Set XLT = XL.Workbooks.open("C:\testfile.xls")
 Set XLT = XLT.Workbooks.Open(strDOT)

Rowss = 16
numrow = 1


While Not (rsd.EOF)
    'смотрим, если строк больше чем мы задали в шаблоне
     If Rowss >= 16 Then
     'то добавляем строку
         XLT.Worksheets("Лист1").Rows(Rowss).Insert
     'Запомним нашу строку
         Set newrow = XLT.Worksheets("Лист1").Rows(Rowss)
     'и вставим туда копию предыдущей строки
     'для того если вдруг у вас там есть объединенные ячейки или какие-то нужные данные
     'так как новая строка создастся без всяких объединений и значений
         XLT.Worksheets("Лист1").Rows(Rowss - 1).Copy newrow
     'динамически формируем адрес нужной ячейки
     cell = "a" & Rowss
     'и задаем ей значение
         XLT.Worksheets("Лист1").Range(cell) = numrow
         cell = "b" & Rowss
         XLT.Worksheets("Лист1").Range(cell) = rsd.Fields("Otchet").Value
         'переходим на следующую строку
     Rowss = Rowss + 1
     'переходим на следующую строку в источнике данных
         rsd.MoveNext
     Else
     'а это выполняется до тех пор, пока не закончатся заданные строки в шаблоне
     'т.е. если строк в источнике всего 1 то в код, который выше мы даже не попадем
         cell = "a" & Rowss
         XLT.Worksheets("Лист1").Range(cell) = numrow
         cell = "b" & Rowss
         XLT.Worksheets("Лист1").Range(cell) = rsd.Fields("Otchet").Value
         Rowss = Rowss + 1
         rsd.MoveNext
     End If
    'для нумерации
         numrow = numrow + 1
'конец цикла
Wend
'делаем Excel видимым
XL.Visible = True
'Очищаем переменные
Set XL = Nothing
Set XLT = Nothing
Set newrow = Nothing

End Sub

Public Function sendEmail(emailTo As String, emailSubject As String, emailBody As String, Optional VarDebug As Boolean) As Integer
On Error GoTo Err_sendEmail
Dim oMSG As Object
Dim oConfig As Object
Dim CFields As Object
Dim strBody As String

Set oMSG = CreateObject("CDO.Message")
Set oConfig = CreateObject("CDO.Configuration")
Set CFields = oConfig.Fields
Set oMSG.Configuration = oConfig

CFields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
CFields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.inbox.ru"
CFields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
'CFields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
CFields("http://schemas.microsoft.com/cdo/configuration/sendusername") = "login" 'Login
CFields("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "parol" 'password
CFields("urn:schemas:mailheader:content-language") = "windows-1251"
CFields.Update

oMSG.To = emailTo
oMSG.From = "login@inbox.ru"
oMSG.Subject = emailSubject
oMSG.BodyPart.Charset = "windows-1251"
'oMSG.AddAttachment "c:\temp\Test0.rtf"
oMSG.TextBody = emailBody
oMSG.Send

sendEmail = 1

Exit_sendEmail:
    Set CFields = Nothing
    Set oConfig = Nothing
    Set oMSG = Nothing
    Exit Function

Err_sendEmail:
    sendEmail = 0
    If Not IsNull(VarDebug) Then If VarDebug Then MsgBox (Err.Description)
    Resume Exit_sendEmail
End Function