1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

23

24

25

Dim xlApp As Object, xlBook As Object, xlSheet As Object

  Dim db As DAO.Database, rsd As DAO.Recordset, rse As DAO.Recordset

  Dim sq$, cs&, TmplFileName$

  Set db = CurrentDb

  sq = "SELECT ... FROM... WHERE... ORDER BY ..." ' выборка данных для первого рекордсета

  Set rsd = db.OpenRecordset(sq, dbOpenSnapshot)

  If rsd.EOF Then Exit Sub ' проверяем на отсутствие записей

  Set xlApp = CreateObject("Excel.Application")

  xlApp.Visible = True

  TmplFileName = CurrentProject.path & "\Dot\test1.xlt" ' здесь указываем путь к шаблону (задал относительно - так удобно при использовании базы на разных компах

  Set xlBook = xlApp.Workbooks.Add(TmplFileName)

  Set xlSheet = xlBook.Sheets(1)

  cs = 0

  Do Until rsd.EOF

    If cs > 0 Then Set xlSheet = xlBook.Sheets.Add(, xlBook.Worksheets(cs), , TmplFileName)

    cs = cs + 1

    xlSheet.Name = ' создаем название листа в формате, например, rsd!Name

    xlSheet.Cells(2, 1).Value = ' аналогично ваяем шапку на листе, если есть необходимость - у меня обычно есть

    sq = "SELECT...FROM ...WHERE ... cat_id = " & rsd!id & "" ' создаем второй рекордсет и склеиваем по нужному полю

    Set rse = db.OpenRecordset(sq, dbOpenSnapshot)

    xlSheet.Cells(8, 2).CopyFromRecordset rse ' заполняем листы

    rsd.MoveNext

  Loop

  Set xlSheet = Nothing: Set xlBook = Nothing: Set xlApp = Nothing

  Set rse = Nothing: Set rsd = Nothing: Set db = Nothing