Делимся наработками

Private Sub Form_Open(Cancel As Integer)
  If Command = "history" Then Exit Sub
.....
End Sub

Private Sub Form_Load()
  If Command = "history" Then Application.Quit
.....
End Sub

Private Sub НазваниеКнопки_Click()
Dim MD
Set MD = Application.FileDialog(1) 
MD.AllowMultiSelect = False 
MD.Title = "Выбор файла" 
MD.Show
If MD.SelectedItems.Count > 0 Then 
XFileDial = MD.SelectedItems(1)
Else
XFileDial = Null
End If
Me.ИмяПоля = XFileDial ' Поле, куда запишется полный путь к выбранному файлу, в свойствах поля надо указать источником данных соответствующее поле MEMO в таблице.
Set MD = Nothing
End Sub

Private Sub НазваниеКнопки_Click()
Shell "explorer.exe " & Me.ИмяПоля, vbNormalFocus
End Sub

Dim rstC As DAO.Recordset
Dim i As Long
Dim lngId As Long
 
    If Me.Dirty = True Then Me.Dirty = False
 
Set rstC = Me.RecordsetClone
    With Me.Recordset
        rstC.AddNew
        lngId = rstC.Fields(0)
            For i = 1 To rstC.Fields.Count - 1  ' - Первое поле счетчик, его не передаем
                rstC.Fields(i) = .Fields(i)
            Next i
        rstC.Update
        .Requery
        .FindLast "[id]=" & CStr(lngId) ' переходим на последнюю запись
    End With
Set rstC = Nothing

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

Public Function DConcat(Expr As String, Domain As String, Optional Criteria As Variant, Optional Delimiter As String)
Dim myRst As Recordset, myVal As Variant, Result As String
On Error GoTo ErrHandler
    ' Используем текстовую переменную Result для формирования текста запроса для Recordset
    Result = "Select " & Expr & " As Expr From " & Domain
    If Criteria > "" Then
        Result = Result & " Where " & Criteria
    End If
    Result = Result & "; "
    Set myRst = CurrentDb.OpenRecordset(Result, 4)
    ' А теперь ее же для хранения результата сцепления строк
    Result = ""
    If myRst.RecordCount > 0 Then
        myRst.MoveFirst
        Do While Not myRst.EOF
            myVal = myRst.Fields("Expr")
            If Not IsNull(myVal) Then
                If Result > "" Then
                    Result = Result & Nz(Delimiter, "") & CStr(myVal)
                  Else
                    Result = CStr(myVal)
                End If
            End If
            myRst.MoveNext
        Loop
    End If
    DConcat = Result
    myRst.Close
    Exit Function
ErrHandler:
    If Not (myRst Is Nothing) Then myRst.Close
    MsgBox "Error in function D_Cocnatenate #" & Err.Number & ": " & Err.Description
End Function

Public Function DConcat(Expr As String, Domain As String, Optional Criteria As Variant = "", Optional Delimiter As String = "")
Dim myRst As Recordset, myVal As Variant, Result As String
On Error GoTo ErrHandler
    '  Если Criteria число или логическое, то в случае равенства 0 функцию не выполняем
    If VarType(Criteria) < 8 Then
        If Criteria = 0 Then
            DConcat = Null
            Exit Function
        End If
    End If
    ' Используем текстовую переменную Result для формирования текста запроса для Recordset
    Result = "Select " & Expr & " As Expr From " & Domain
    If Criteria > "" Then
        Result = Result & " Where " & Criteria
    End If
    Result = Result & "; "
    Set myRst = CurrentDb.OpenRecordset(Result, 4)
    '  А теперь ее же для хранения результата сцепления строк
    Result = ""
    If myRst.RecordCount > 0 Then
        myRst.MoveFirst
        Do While Not myRst.EOF
            myVal = myRst.Fields("Expr")
            If Not IsNull(myVal) Then
                If Result > "" Then
                    Result = Result & Nz(Delimiter, "") & CStr(myVal)
                  Else
                    Result = CStr(myVal)
                End If
            End If
            myRst.MoveNext
        Loop
    End If
    DConcat = Result
    myRst.Close
    Exit Function
ErrHandler:
    If Not (myRst Is Nothing) Then myRst.Close
    MsgBox "Error in function D_Cocnatenate #" & Err.Number & ": " & Err.Description
End Function