Private Sub OK_2_Click()
On Error Resume Next
Dim Book1 As String:    Book1 = Access.CurrentProject.path & "\book1.xls"
Dim List1 As String:    List1 = "имя листа"

If Dir(Book1) <> "" Then
    Kill Book1
    If Err.Number <>  0  Then
        Err.Clear
        MsgBox "не могу удалить прежний " & vbCrLf & Book1
        Exit Sub
    End If
End If

On Error GoTo err1

Dim XL As Excel.Application             'Microsoft Excel ?? Object Library
Dim BK As Excel.Workbook
Dim SH As Excel.Worksheet

Set XL = New Excel.Application

XL.Application.ScreenUpdating = False
XL.Visible = False

XL.Workbooks.Add
XL.Sheets( 1 ).Name = List1
XL.Workbooks( 1 ).SaveAs (Book1)          'создадим пустой excel-файлик
    
Set BK = XL.Workbooks.Open(Book1)       'открываем для заполнения
Set SH = BK.Worksheets(List1)

'заполняем значениями
    Dim rst As ADODB.Recordset:     Set rst = New ADODB.Recordset
    Dim cmd As ADODB.Command:       Set cmd = New ADODB.Command
    Dim prm As ADODB.Parameter:     Set prm = New ADODB.Parameter
        
    With cmd
        .ActiveConnection = CurrentProject.Connection
        .CommandText = "SELECT * FROM [Продажи по годам]"
        .CommandType = adCmdText
        
        Set prm = .CreateParameter("date1", adDate, adParamInput)
        .Parameters.Append prm
        Set prm = .CreateParameter("date2", adDate, adParamInput)
        .Parameters.Append prm
        
        .Parameters("date1") = Me.НачальнаяДата
        .Parameters("date2") = Me.КонечнаяДата
    End With
    
    Dim i As Long:  i =  1 
    
    Set rst = cmd.Execute
    
    Do While Not rst.EOF
        i = i +  1 
        SH.Cells(i,  1 ) = rst!ДатаИсполнения     'дата в excel-файле, получается нормальная
        SH.Cells(i,  2 ) = rst!ПромежуточнаяСумма
        rst.MoveNext
    Loop
    
    Set rst = Nothing
    Set cmd = Nothing
    Set prm = Nothing

'начинаем оформлять
'так

SH.Cells( 1 ,  1 ) = "Дата Исполнения"
SH.Cells( 1 ,  2 ) = "Промежуточная Сумма"

SH.Rows("1:1").Font.Bold = True         'для всей строки
SH.Rows("1:1").WrapText = True
SH.Rows("1:1").HorizontalAlignment = xlCenter   ' xlRight xlLeft
SH.Rows("1:1").VerticalAlignment = xlCenter
SH.Rows("1:1").RowHeight =  40 

SH.Columns( 1 ).ColumnWidth =  15           'для всей колонки
SH.Columns( 1 ).NumberFormat = "m/d/yyyy"
SH.Columns( 2 ).ColumnWidth =  15           'для всей колонки
SH.Columns( 2 ).NumberFormat = "0.00"

With SH.PageSetup
    .PrintTitleRows = "$1:$1"           'повторять при печати первую строку
    .RightHeader = "Страница &P"
End With

BK.Save
BK.Close
XL.Quit                                 'обязательно Quit, иначе excel останется в памяти
Set XL = Nothing

err1:

    If Err.Number <>  0  Then
        MsgBox Err.Description
        On Error Resume Next
        XL.Quit                         'обязательно Quit, иначе excel останется в памяти
        Set XL = Nothing
    End If

End Sub