Форумы HiProg.com - MS ACCESS, VBA, VB

ник: KrukVN
тогда так:

Sub StartRpt_Schet(ByVal qryName As String, ByVal QryCriteria As String, ByVal strHeader As String) On Error GoTo Err_StartRpt_Schet Dim xlSheet As Excel.Worksheet Dim xlApp As Excel.Application Dim xlBook As Excel.Workbook Dim MyRange As Excel.Range Dim ExportFile As String Dim NumRow As Long ExportFile = CurrentProject.Path & "\Отчет от " & Format(Date, "dd mm yy") 'Имя сохраняемого файла If ExportFile = "" Then Exit Sub Set xlApp = CreateObject("Excel.Application") Set xlBook = xlApp.Workbooks.Add 'Создание файла Excel 'Сохранение файла под именем = ExportFile xlBook.SaveAs FileName:=ExportFile, _     FileFormat:=xlNormal, Password:="", WriteResPassword:="", _     ReadOnlyRecommended:=False, CreateBackup:=False 'Закрыть файл xlBook.Close False 'Экспорт данных в предварительно созданный файл DoCmd.SetWarnings 0 'Подавление сообщений Access (на добавление записей)     DoCmd.RunSQL "SELECT " & qryName & ".* INTO " & qryName & " IN '" & ExportFile & "'[Excel 8.0;HDR=YES;IMEX=2] FROM " & qryName & QryCriteria & ";" DoCmd.SetWarnings -1 'Включаем вывод сообщений Set xlBook = xlApp.Workbooks.Open(ExportFile) 'Открыть файл Set xlSheet = xlBook.Worksheets(qryName) 'xlApp.Visible = True 'Показать объект Excel 'xlApp.ScreenUpdating = False 'Выключить обновление экрана Excel xlBook.Sheets(qryName).Move Before:=xlBook.Sheets(1) 'Переместить лист With xlSheet     .Cells(1, 1).Select     .Cells.Font.Name = "Times New Roman"     .Application.Selection.CurrentRegion.Select     .Application.Selection.Borders.Weight = xlThin          .Application.Selection.SpecialCells(xlCellTypeLastCell).Select         NumRow = .Application.Selection.Row 'Номер последней строки     .Cells(1, 1).Select     'Подпись таблицы     .Cells(1, 1).EntireRow.Insert     Set MyRange = .Range(.Cells(1, 1), .Cells(1, 6))     MyRange.Merge     MyRange = UCase(strHeader) & Chr(10) & "по состоянию на " & Format(Date, "dd mmmm yyyy") & " г."     MyRange.Font.Size = 10     'Подпись колонок таблицы и указание ширины столбцов     .Cells(2, 1) = "№" & Chr(10) & "п/п"     .Cells(2, 2) = "Дата счета"     .Cells(2, 3) = "Организация"     .Cells(2, 4) = "Наименование работ/услуг"     .Cells(2, 5) = "Сумма счета"     .Cells(2, 6) = "Дата оплаты"     .Columns(1).ColumnWidth = 5.57     .Columns(2).ColumnWidth = 10     .Columns(3).ColumnWidth = 25     .Columns(4).ColumnWidth = 25     .Columns(5).ColumnWidth = 10     .Columns(6).ColumnWidth = 10     'Выравнивание по горизонтальному центру     .Rows("1:2").VerticalAlignment = xlCenter     .Rows("1:2").HorizontalAlignment = xlCenter     'Высота строки для шапки     .Rows("1:2").RowHeight = 35     'Жирним подпись таблицы и ее шапку     .Rows("1:2").Font.Bold = True     'Включаем нумерацию строк     .Range(.Cells(3, 1), .Cells(NumRow + 1, 1)).FormulaR1C1 = "=ROW()-2"     .Range(.Cells(3, 1), .Cells(NumRow + 1, 1)).HorizontalAlignment = xlCenter     'Формат отображения сумм     .Range(.Cells(3, 5), .Cells(NumRow + 2, 5)).NumberFormat = "#,##0"     'Разрешить перенос слов в ячейках     .Range(.Cells(1, 1), .Cells(NumRow + 1, 6)).Cells.WrapText = True     'Выравнивание по вертикальному центру     .Range(.Cells(3, 1), .Cells(NumRow + 1, 6)).VerticalAlignment = xlTop     'Итоговая запись с суммированием по столбцу     .Cells(NumRow + 2, 4) = "Всего"     .Rows(NumRow + 2).Font.Bold = True     .Cells(NumRow + 2, 5).FormulaR1C1 = "=SUM(R[-" & NumRow - 1 & "]C:R[-1]C)"     .Cells(2, 2).Select     'Поиск vbNewLine и замена на Chr(10). Excel не понимает Chr(13),     'но ставит, почему-то квадратик (как неопознаный символ) + Chr(10)     xlApp.DisplayAlerts = False 'Подавление сообщений Excel, на тот случай если не окажется искомых к замене записей         xlApp.Cells.Replace What:=vbNewLine, Replacement:=Chr(10), LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False     xlApp.DisplayAlerts = True 'Включение сообщений End With 'xlApp.ScreenUpdating = True 'Включить обновление экрана Excel xlApp.Visible = True 'Показать объект Excel xlBook.Save 'Сохранить все изменения Set xlApp = Nothing Set xlBook = Nothing Exit Sub Err_StartRpt_Schet:     Call ErrorBases(err) End Sub

что не понятно, спрашивайте