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