Sub test_read_db_write_excel()

'---- Экспорт данных из базы данных в Excel таблицу ----------

'---- Моксва курс "Хранилища данных"

'---- доцент Герасимов Н.А. 2009 г.

'-----------------------------------------------------------------------------------------

'----- 1 Определение источника данных ------------

Provider = "Microsoft.Jet.OleDB.4.0"

dbName = "D:\Учебные пособия\Учебное пособие по ХД\Northwind.mdb"

ConnStr = "Provider=" & Provider & "; Data Source=" & dbName

MsgBox "ConnStr=" & ConnStr

'--- создание объекта для связи с источником ----

Set db = CreateObject("ADODB.Connection")

'---- открыть источник ----------------

db.Open ConnStr

'---- 2 чтение данных из источника --------------------

'------ SQL- запрос ------------------------------

SqlStr = "SELECT * FROM Customers;"

'--- создание приемника данных ------------------

Set rs = CreateObject("ADODB.RecordSet")

'---- чтение данных их таблицы --------------

rs.Open SqlStr, db

'---3 Определение приемника данных ---

xlsName = "D:\Example1.xls"

Rabtab = "Лист1"

tt = "Отчет по запросу=" & SqlStr

'--- Создание новой пустой книги ---

Workbooks.Add

'---4 - Вывод данных в новую таблицу ---

Sheets(Rabtab).Select

'---- Вывод отчета на лист ------

nstr = 0

Sheets(Rabtab).Cells(nstr + 1, 1).Value = tt

'--- определить кол-во столбцов в отчете ------

nn = rs.Fields.Count - 1

'-------------------

nstr = nstr + 2

'------ вывод строки заголовков отчета на лист ----

For i = 0 To nn

rr = rs.Fields(i).Name

Sheets(Rabtab).Cells(nstr + 1, i + 1).Value = rr

Next

'------ Вывод строк отчета на лист----

nstr = nstr + 1

Do Until rs.EOF = True

For i = 0 To nn

rr = rs.Fields(i).Value

Sheets(Rabtab).Cells(nstr + 1, i + 1).Value = rr

Next

'--- переход к следующей строке ---

nstr = nstr + 1

rs.MoveNext

Loop

'---- сохранение новой книги под именем -----

ActiveWorkbook.SaveAs Filename:=xlsName, FileFormat:=xlNormal, _

Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _

CreateBackup:=False

ActiveWorkbook.Close

'----- Вывод сообщения об окончании процедуры экспорта ----

tt = "Эксрпорт данных " & Chr(10)

tt = tt & "Из -->" & dbName & Chr(10)

tt = tt & "в <--" & xlsName & Chr(10)

tt = tt & "***Закончен***"

MsgBox tt