MS Excel - Альтернативный метод экспорта данных

Автор: Кривцов Анатолий

Метод заключается в создании(изменении) рабочей книги при помощи библиотеки объектов Excel. Те, кто знает предмет, или кого устраивает вид рабочего листа при экспорте отчета с группировками - могут дальше не читать.

Преимущества:
    Можно получить полностью оформленный документ;  
    Можно внести данные из разных источников на отдельные листы и даже на один лист рабочей книги;
    Можно обновить данные в существующем файле в тех клетках, где они были внесены ранее.

ОБЯЗАТЕЛЬНО! должна быть установлена ссылка на Microsoft Excel X.X Object Library.
Желательно проверять корректность ссылки перед запуском процедуры. (Или обьявляйте все обьекты Excel As Object - пойдёт)

      Приводится два примера. Оба рабочие и могут быть использованы за основу Ваших примочек.
Первый пример демонстрирует использование основных объектов, свойств и методов библиотеки Excel. В новом файле создается и форматируется простая табличка с формулами

Первый Пример:

Sub TestExcel_1()

On Error GoTo TestExcel_1_err
'Создается новый экземпляр Excel.
Dim ExlDb As New Excel.Application
'Объекты Excel: Workbook - рабочая книга, Worksheet - рабочий
'лист, Range - любой диапазон клеток.
Dim WrkBk As Workbook, WrkSht As Worksheet, _
rngActive As Range, rngInput As Range

' Окно Excel становится видимым. Вставлено в начало процедуры
'для отладки. В отлаженной процедуре лучше перенести в конец.
ExlDb.Visible = True
'Создается новая рабочая книга.
Set WrkBk = ExlDb.Workbooks.Add
'Устанавливается ссылка на активный рабочий лист
Set WrkSht = WrkBk.ActiveSheet
'Устанавливается ссылка на клетку А1 и передается фокус.
Set rngActive = WrkSht.Cells(1, 1)
rngActive.Activate

'В А1 вносится заголовок, меняется размер и толщина шрифта.
'Затем выполняется объединение клеток А1:D4, выравнивание
'по центру(по вертикали и горизонтали) и увеличение высоты
'строки в 2 раза.
rngActive = "Остатки товара на складе."
rngActive.Font.Size = 12
rngActive.Font.Bold = True

With WrkSht.Range(rngActive, rngActive.Offset(0, 3))
.Merge
.HorizontalAlignment = xlHAlignCenter
.VerticalAlignment = xlVAlignCenter
.RowHeight = .RowHeight * 2
End With
'rngActive перемещается на А2 и выполняется оформление шапки.
Set rngActive = rngActive.Offset(1)
With rngActive
.Value = "Наименование товара"
.Offset(0, 1) = "Кол-во"
.Offset(0, 2) = "Цена"
.Offset(0, 3) = "Сумма"
End With

With WrkSht.Range(rngActive, rngActive.Offset(0, 3))
.Borders.LineStyle = xlContinuous 'Разлиновка
.HorizontalAlignment = xlHAlignCenter
.Interior.Color = RGB(220, 220, 220) 'Серый цвет
' Примечание: Хотя функция RGB принимает значения параметров
'в интервале 0-255, клетка принимает в качестве фона комбинацию
'из 0(нет цвета),255(максимальная яркость),220(полутон).
'Может быть есть и другие варианты, но я не нашел.
.Font.Bold = True
End With

'rngActive перемещается на А3 и создается ссылка на область данных (A3:D4).

Set rngActive = rngActive.Offset(1)
Set rngInput = WrkSht.Range(rngActive, rngActive.Offset(0, 3))

'Далее вносятся данные в две строки. Здесь, конечно, просится
'цикл обработки записей в Recordset.

With rngActive
.Value = "Шило"
.Offset(0, 1) = "100"
.Offset(0, 2) = "5"
End With

Set rngActive = rngActive.Offset(1)
With rngActive
.Value = "Мыло"
.Offset(0, 1) = "200"
.Offset(0, 2) = "10"
End With

'По завершении ввода rngActive указывает на последнюю строку
'с данными. Количество строк в диапазоне rngInput изменяется
'(rngActive.row-посленяя строка, rngInput.row-первая строка)
'В данном случае - A3:D4.
Set rngInput = rngInput.Resize(rngActive.row - _
rngInput.row + 1)
'rngActive - 4-й столбец в первой строке rngInput(D3).
Set rngActive = WrkSht.Cells(rngInput.row, 4)
With rngActive
'В клетку D3 Создается формула "=B3*C3"
.Formula = _
"=" & .Offset(0, -2).Address(False, False) & "*" _
& .Offset(0, -1).Address(False, False)
'Формула(и формат) копируется во все клетки 4-го столбца,
'входящие в rngInput(D3:D4).
.Copy rngInput.Columns(4)
'Примечание: Если нужно скопировать только формулу - нужно
'применить следующую конструкцию:
' .Copy - копирование в буфер.
' rngInput.Columns(4).PasteSpecial (xlPasteFormulas)
End With

'Последняя строка подчеркивается сплошной жирной линией.
With rngInput
.Borders.LineStyle = xlContinuous
.Borders(xlEdgeBottom).wEight = xlThick
End With

'rngActive - 3-й столбец в первой пустой строке(C5).
'Свойство UsedRange указывает на диапазон с А1 по правую-нижнюю
'занятую клетку.
'Примечание: Здесь есть хитрость. Подчеркивание жирной линией
'добавляет в UsedRange и следующую строку. В обычном случае
'номер пустой строки определяется как "UsedRange.Rows.Count+1".

With WrkSht
Set rngActive = .Cells(.UsedRange.Rows.Count, 3)
End With

'В C5 вносится "Всего:" и выравнивается вправо.
rngActive = "Всего:"
rngActive.HorizontalAlignment = xlHAlignRight
rngActive.Font.Bold = True

'В D5 вносится формула "=SUM(D3:D4)"
Set rngActive = rngActive.Offset(0, 1)
rngActive.Formula = "=sum(" _
& rngInput.Columns(4).Address(False, False) & ")"
rngActive.Font.Bold = True

'Столбцам C и D присваивается числовой формат и устанавливается
'"Автоширина" столбцов A-D.
With WrkSht
.Columns(1).AutoFit
.Columns(2).AutoFit
.Columns(3).NumberFormat = "#,##0.00"
.Columns(3).AutoFit
.Columns(4).NumberFormat = "#,##0.00"
.Columns(4).AutoFit
End With

' ExlDb.Visible = True

TestExcel_1_exit:
On Error Resume Next
Set rngInput = Nothing
Set rngActive = Nothing
Set WrkSht = Nothing
Set WrkBk = Nothing
Set ExlDb = Nothing

Exit Sub

TestExcel_1_err:
MsgBox Err & " - " & Err.Description, vbCritical
Resume TestExcel_1_exit
End Sub

Второй пример:

'Второй пример демонстрирует обновление данных в существующем
'файле. Комментарии даются только свойствам и методам, не описанным выше.

Sub TestExcel_2()
On Error GoTo TestExcel_2_err
Dim ExlDb As New Excel.Application
Dim WrkBk As Workbook, WrkSht As Worksheet, _
rngActive As Range, rngFind As Range, rngNew As Range
Dim boolIsNewBook As Boolean, boolIsSheetName As Boolean

Const strSheetName = "DataAccess"
Const strPathFile = "C:\TestExcel_2.xls"

'Открывает окно Exсel в виде иконки.
ExlDb.WindowState = xlMinimized
ExlDb.Visible = True

If strPathFile = "" Or Dir$(strPathFile) = "" Then
'Если файл не найден - формируется новая рабочая книга.
'Активному листу присваивается имя из strSheetName.
'Устанавливается флажок boolIsNewBook.
Set WrkBk = ExlDb.Workbooks.Add
Set WrkSht = WrkBk.ActiveSheet
WrkSht.Name = strSheetName
boolIsNewBook = True
Else
'Если файл найден - загружается в Excel.
Set WrkBk = ExlDb.Workbooks.Open(strPathFile)
'Выполняется поиск листа с указанным именем.
'Если найден - становится активным и устанавливается
'флажок boolIsSheetName.
For Each WrkSht In WrkBk.Worksheets
If WrkSht.Name Like strSheetName Then
boolIsSheetName = True
WrkSht.Activate
Exit For
End If
Next WrkSht

If Not boolIsSheetName Then
MsgBox " В файле " & strPathFile & " отсутствует лист" _
& " с именем " & Chr(34) & strSheetName & Chr(34) _
& ", на которую вносятся данные для отчета.@@" _
& " Процедура прервана!", vbCritical
GoTo TestExcel_2_exit
End If
End If

With WrkSht
If boolIsNewBook Then
Set rngActive = .Cells(1, 1) 'A1
rngActive = "ID"
rngActive.Offset(0, 1) = "Наименование"
rngActive.Offset(0, 2) = "Сумма"
End If

Set rngActive = .Cells(2, 1) 'A2
rngActive.Offset(0, 2).Activate 'Фокус на C2

If Not boolIsNewBook And .UsedRange.Rows.Count >= 2 Then
'rngNew - клетка во второй пустой строке и 1-м столбце.
'Используется для добавления новых записей.
Set rngNew = .Cells(.UsedRange.row + _
.UsedRange.Rows.Count + 1, 1)
'rngFind - диапазон для поиска идентификатора записи.
'Указывает на клетки 1-го столбца со 2-й по последнюю занятую
'строку на листе.
Set rngFind = .Range(rngActive, rngNew.Offset(-2, 0))
'Очищаются все клетки с B2 по правую нижнюю занятую клетку.
.Range(.Cells(2, 2), rngNew.Offset(0, .UsedRange.Column + _
.UsedRange.Columns.Count - 1)).Clear
Else
'Если новый файл - rngNew указывает на A2
Set rngNew = rngActive
Set rngFind = Nothing
End If
End With

Set rngActive = Nothing

'Обрабатываются два произвольных варианта. Реально здесь должен
'быть Recordset и вместо констант ID1,ID2 указывается значение
'ключевого поля.
'Для контроля работы процедуры можно поменять значения констант
'местами, а затем изменить значение ID1 на 3.
Const ID1 = 1
Const ID2 = 2

'Если ссылка на rngFind установлена - выполняется поиск значения.
If Not rngFind Is Nothing Then
Set rngActive = rngFind.Find(ID1, , xlValues, _
xlWhole, xlByRows, xlNext)
End If

If rngActive Is Nothing Then
'Если значение НЕ найдено, то ввод будет выполняться в строку,
'на которую указывает rngNew, а затем rngNew перемещается
'на строку ниже.
With rngNew
.Value = ID1
.Offset(0, 1) = "Шило"
.Offset(0, 2) = "100"
End With
Set rngNew = rngNew.Offset(1, 0)

Else
'Если значение найдено (rngInput указывает на найденную клетку),
'ввод выполняется в эту строку.
With rngActive
.Offset(0, 1) = "Шило"
.Offset(0, 2) = "100"
End With
Set rngActive = Nothing
End If
'-------- Второй вариант. Только для примера. --------------
If Not rngFind Is Nothing Then
Set rngActive = rngFind.Find(ID2, , xlValues, _
xlWhole, xlByRows, xlNext)
End If

If rngActive Is Nothing Then
With rngNew
.Value = ID2
.Offset(0, 1) = "Мыло"
.Offset(0, 2) = "200"
End With
Set rngNew = rngNew.Offset(1, 0)
Else
With rngActive
.Offset(0, 1) = "Мыло"
.Offset(0, 2) = "200"
End With
Set rngActive = Nothing
End If
'-----------------------------------------------------------

'Разворачивание окна Excel
ExlDb.WindowState = xlMaximized
'Сохранение файла на диске.
WrkBk.SaveAs strPathFile

TestExcel_2_exit:
On Error Resume Next
Set rngFind = Nothing
Set rngNew = Nothing
Set rngActive = Nothing
Set WrkSht = Nothing
Set WrkBk = Nothing
Set ExlDb = Nothing

Exit Sub

TestExcel_2_err:
Select Case Err
Case 1004 'Отказ от сохранения
Case Else
MsgBox Err & " - " & Err.Description, vbCritical
End Select
Resume TestExcel_2_exit
End Sub