Private Sub Button5_Click()
On Error GoTo Err_Button5_Click

  DoCmd.OpenForm "Form2"
  
Exit_Button5_Click:
  Exit Sub

Err_Button5_Click:
  MsgBox Err.Description
  Resume Exit_Button5_Click

End Sub

Private Sub Button1_Click()
On Error GoTo Err_Button1_Click

  Screen.MousePointer =  11 
  Call QueriesList
  MsgBox Prompt:="Экспорт завершен!"
  DoCmd.Close
  
Exit_Button1_Click:
  Screen.MousePointer =  0 
  Exit Sub

Err_Button1_Click:
  MsgBox Err.Description
  Resume Exit_Button1_Click

End Sub

Option Compare Database
Public xlsApp As Excel.Application

Public Sub RunPrepare(mm As String, yy As String)
 ' некоторая вспомогательная функция, которая вызывается в другом контексте 
End Sub

Public Sub QueriesList()
On Error GoTo Err_QueriesList

  Dim dbs  As DAO.Database
  Dim tdf As DAO.TableDef
  Dim qdf As DAO.QueryDef
  Dim qdfFls As DAO.QueryDef
  Dim fld As DAO.Field
  Dim rst As DAO.Recordset
  Dim rstFls As DAO.Recordset
  Dim epath As String
  Dim last As Integer
  
  Set xlsApp = New Excel.Application
  xlsApp.DisplayAlerts = False
  xlsApp.Visible = True
  
  Set dbs = CurrentDb
  Set qdfFls = dbs.CreateQueryDef("")
  qdfFls.SQL = "SELECT fvalue FROM SysParams WHERE fkey=""exp_path"""
  Set rstFls = qdfFls.OpenRecordset
  epath = rstFls.Fields( 0 )
  rstFls.Close
  
  qdfFls.SQL = "SELECT COUNT(*) FROM SysQuery1"
  Set rstFls = qdfFls.OpenRecordset
    
  Form_Form2.ProgressBar1.Value =  0 
  Form_Form2.ProgressBar1.Min =  0 
  Form_Form2.ProgressBar1.Max = rstFls.Fields( 0 )
  
  rstFls.Close
  
  Set qdfFls = dbs.QueryDefs!SysQuery1
  Set rstFls = qdfFls.OpenRecordset
  
  last =  0 
  rstFls.MoveFirst
  Do While Not rstFls.EOF
    Form_Form2.ProgressBar1.Value = Form_Form2.ProgressBar1.Value +  1 
    Set qdf = dbs.QueryDefs(rstFls.Fields("fquery"))
    Set rst = qdf.OpenRecordset
    last = ExportQuery(epath + rstFls.Fields("ffile"), rstFls.Fields("fsheet"), rst, last)
    rstFls.MoveNext
  Loop
  
Exit_QueriesList:
  xlsApp.Quit
   'Set xlsApp = Nothing 
  Exit Sub
  
Err_QueriesList:
  MsgBox Err.Description
  Resume Exit_QueriesList
  
End Sub

Public Function ExportQuery( _
p_file As String, p_sheet As String, p_rst As DAO.Recordset, Optional p_row As Integer =  0 ) As Integer

On Error GoTo Err_ExportQuery

  Dim xlsWbook As Excel.Workbook
  Dim xlsWsheet As Excel.Worksheet
  Dim fld As DAO.Field
  Dim i, j As Integer
  
  If Dir(p_file) = "" Then
    Set xlsWbook = xlsApp.Workbooks.Add(xlWBATWorksheet)
    Set xlsWsheet = xlsWbook.Worksheets( 1 )
    xlsWsheet.Name = p_sheet
    xlsWsheet.Activate
    i =  1 
  Else
    Set xlsWbook = xlsApp.Workbooks.Open(p_file)
    For Each xlsWsheet In xlsWbook.Worksheets
      If xlsWsheet.Name = p_sheet Then Exit For
    Next
    If xlsWsheet Is Nothing Then
      Set xlsWsheet = xlsWbook.Worksheets.Add
      xlsWsheet.Name = p_sheet
      i =  1 
    Else
      i = p_row +  1 
    End If
    xlsWsheet.Activate
  End If
  
  j =  1 
  For Each fld In p_rst.Fields
    xlsWsheet.Cells(i, j).Select
    Selection.NumberFormat = "@"
    xlsWsheet.Cells(i, j) = fld.Name
    j = j +  1 
  Next
  j =  1 : i = i +  1 
  p_rst.MoveFirst
  Do While Not p_rst.EOF
    For Each fld In p_rst.Fields
      xlsWsheet.Cells(i, j) = fld.Value
      j = j +  1 
    Next
    j =  1 : i = i +  1 
    p_rst.MoveNext
  Loop
  xlsWbook.Close True, p_file

  ExportQuery = i
  
Exit_ExportQuery:
  Exit Function
  
Err_ExportQuery:
  MsgBox Err.Description
  Resume Exit_ExportQuery
  
End Function

    xlsSheet.Cells(i, j).Select
    xlsApp.Selection.NumberFormat = "@"

    xlsSheet.Cells(i, j).Select
    Selection.NumberFormat = "@"