Public Function acbCreateExcel(strRst As String, strExcelName As String, _
            strRstSheetName As String, Optional intCropEndColumns As Integer = 0)
' создает книгу strExelName(полный путь),
' добавляет в нее лист strRstSheetName с данными strRst (таблица или запрос)
' intCropEndColumns - число обрезаемых столбцов справа
Dim intRow As Integer
Dim intCol As Integer

DoCmd.Hourglass True
    Set xlw = CreateObject("Excel.Sheet")
    Set xla = xlw.Parent
    Set xls = xlw.ActiveSheet
DoCmd.Hourglass False
    acbRstToSheet xls, strRst, strExcelName, strRstSheetName, intCropEndColumns
    xlw.SaveAs strExcelName
    xlw.Close
    xla.Quit
    Set xls = Nothing
    Set xlw = Nothing
    Set xla = Nothing
End Function

Private Function acbRstToSheet(xlSheet As Object, strRst As String, strExcelName As String, strSheetName As String, _
                               Optional intCropEndColumns As Integer = 0)
Dim dbs As Database
Dim rst As Recordset
Dim intRow As Integer
Dim intCol As Integer

DoCmd.Hourglass True
    Set dbs = CurrentDb()
    Set rst = dbs.OpenRecordset(strRst)
        
    xlSheet.Name = strSheetName

    intRow = 1
    For intCol = 1 To rst.Fields.Count - intCropEndColumns
        xlSheet.Cells(intRow, intCol).Value = rst(intCol - 1).Name
        xlSheet.Cells(intRow, intCol).HorizontalAlignment = xlCenter
        xlSheet.Cells(intRow, intCol).Font.Bold = True
        'xlSheet.Cells(intRow, intCol).Interior.ColorIndex = 15
    Next intCol
    intRow = 2
    If rst.RecordCount > 0 Then
        rst.MoveFirst
        Do Until rst.EOF
            For intCol = 1 To rst.Fields.Count - intCropEndColumns
                If (Not IsNull(rst(intCol - 1))) Then
                    xlSheet.Cells(intRow, intCol).Value = CStr(rst(intCol - 1))
                End If
            Next intCol
            rst.MoveNext
            intRow = intRow + 1
        Loop
        For intCol = 1 To rst.Fields.Count
            xlSheet.Columns(intCol).Font.Name = "Tahoma"
            xlSheet.Columns(intCol).Font.SIZE = 8
            xlSheet.Columns(intCol).AutoFit
        Next intCol
    End If
    rst.Close
    Set rst = Nothing
    dbs.Close
    Set dbs = Nothing
DoCmd.Hourglass False
  
End Function