Sub test_read_excel_write_db()

'---- Импорт данных из Excel таблицы в базу данных ----------

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

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

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

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

xlsName = "D:\Example1.xls"

RabTab = "Лист1"

nstr = 2 ' номер строки, в которой наименования столбцов

'---- открыть книгу ----

Workbooks.Open Filename:=xlsName

Sheets(RabTab).Select

'---- Чтение списка имен столбцов -----------

ncol = 1

Dim TypeD(100)

With Sheets(RabTab)

Do

rr = .Cells(nstr + 1, ncol).Value

If rr = "" Then Exit Do

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

TypeD(ncol) = .Cells(nstr, ncol).Value

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

ncol = ncol + 1

Loop

End With

tt = "Количество столбцов в таблице =" & ncol

MsgBox tt

'--- 2 Определить приемник данных

Provider = "Microsoft.Jet.OleDB.4.0"

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

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

tabName = "Customers" ' имя таблицы в базе данных

MsgBox "ConnStr=" & ConnStr

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

Set Db = CreateObject("ADODB.Connection")

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

Db.Open ConnStr

'---4--- очистить таблицу приемник ---------------------

Set rs = CreateObject("ADODB.RecordSet")

strSql = "DELETE * FROM " & tabName

rs.Open strSql, Db

'---- 5 Запись данных в приемник --------------------

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

strSql0 = "INSERT INTO " & tabName & " VALUES ( $ss$ )"

' MsgBox "strsql0-->" & strSql0

With Sheets(RabTab)

nstr = nstr + 2

Do

rr = .Cells(nstr, 1).Value

If rr = "" Then Exit Do

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

ss = ""

For k = 1 To ncol - 1

ss1 = "'": If TypeD(k) = "i" Or TypeD(k) = "c" Then ss1 = ""

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

rr1 = .Cells(nstr, k).Value

rr1 = Replace(rr1, "'", "")

ss0 = ss1 & rr1 & ss1

ss = ss & "," & ss0

'MsgBox ss

Next

ss = Mid(ss, 2)

strSql = Replace(strSql0, "$ss$", ss)

'MsgBox strSql

'--------- запись данных в таблицу базы ----------

rs.Open strSql, Db

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

nstr = nstr + 1

Loop

End With

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

'-----

tt = "Импорт данных " & Chr(10)

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

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

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

MsgBox tt