asdfqwerzxc

Представим себе такую задачу:

Есть две экселевские таблицы. Это могут быть и два разных листа одной книги и две отдельные книги. Их может быть и больше. И вам надо сопоставить ячейки одной таблицы с ячейками другой, чтоб получить значения из её строки. За пределами экселя это делается с помощью SQL. В самом экселе с каких-то пор появилась некая химера под названием PowerQuery, но ну её нафиг.

В составе офиса у нас уже есть DAO. Это ядро баз данных, используемое MS Access-ом - Jet. Его и будем использовать.

1. Сохраняем область ячеек одной из из исходных таблиц в xls-файл. Например это от A1 до B100

   Dim wt As Workbook, sht As Worksheet 'временная книга

   Dim sh1 As Worksheet 'первый лист-источник

   Dim cStart As String, cEnd As String

   Set sh1 = ThisWorkbook.Worksheets(1)

   Set wt = Application.Workbooks.Add

   Set sht = wt.Worksheets(1)

   cStart ="A1" 'первая ячейка

   cEnd = "B100" 'сотая строка в столбце B

   sh1.Range(cStart & ":" & cEnd).Copy sht.Range("A1")

   Application.DisplayAlerts = False

   Set WShell = CreateObject("WScript.shell")

   strFile1 = WShell.ExpandEnvironmentStrings("%temp%") & "\file1.xls"

   wt.SaveAs strFile1, XlFileFormat.xlExcel8

   wt.Close

   Application.DisplayAlerts = True

Всё то же самое делаем с другой таблицей. Главное, чтоб выходной файл имел другое название.

2. Создаём MDB-файл

Dim strSQL As String

Dim dbs As DAO.Database, rst As DAO.Recordset, qdf As DAO.QueryDef

Dim strMDB As String

Dim WShell

Set WShell = CreateObject("WScript.shell")

strMDB = WShell.ExpandEnvironmentStrings("%temp%") & "\mdb.mdb"

If FileExists(strMDB) Then Kill strMDB

If CreateDataBaseDAO(strMDB) Then

Set dbs = DAO.OpenDatabase(strMDB)

'создаём таблицу и поля

Set tdf = dbs.CreateTableDef("t1")

Set fld1 = tdf.CreateField("f1", dbText, 255)

tdf.Fields.Append fld1

Set fld1 = tdf.CreateField("f2", dbText, 255)

tdf.Fields.Append fld1

dbs.TableDefs.Append tdf

'создадим запрос на копирование строчек из файла в базу и выполним его

Set qdf = dbs.CreateQueryDef("q1", "insert into t1 SELECT * FROM [Лист1$] AS s_ IN '" & strFile1 & "'[EXCEL 8.0;HDR=no;];")

qdf.Execute

Так же создаём и заполняем столько таблиц, сколько нам надо связать в запросе.

И делаем простенький запрос на выборку со связыванием:

strSQL = "SELECT t1.F1, t1.F2, t2.F1 " & vbCrLf & _

"FROM t1 LEFT JOIN dst ON t1.F1 = t2.F1 " & vbCrLf & _

"WHERE t1.F1 Is Not Null AND t2.F1 Is Null;"

Set qdf = dbs.CreateQueryDef("qCompare", strSQL)

Set rst = dbs.OpenRecordset("qCompare")

If Not rst.EOF Then

While Not rst.EOF

'Debug.Print rst.Fields(0), rst.Fields(1)

rst.MoveNext

Wend

End If

Таким образом формируется запрос, в котором вывелись записи из первой таблицы, для которых не нашлось сопоставление во второй. Можем в цикле вывести эти записи в нашу книгу, например.

В коде встречаются две функции. Вот их код:

Function FileExists(strFile As String) As Boolean

On Error GoTo erro

If FileLen(strFile) <> 0 Then FileExists = True

Exit Function

erro:

If Err.Number = 53 Then FileExists = False

End Function

Function CreateDataBaseDAO(newDB As String, Optional sLocate As String = dbLangCyrillic, Optional iVersion As Integer = dbVersion40) As Boolean

Dim dbNew As Database

On Error GoTo Proc_Err

Set dbNew = DBEngine.CreateDatabase(newDB, sLocate, iVersion)

CreateDataBaseDAO = True

Proc_Exit:

Exit Function

Proc_Err:

MsgBox Err.Description, , Err.Number

CreateDataBaseDAO = False

Resume Proc_Exit

End Function

Самая затратная по времени выполнения часть - это копирование записей из файлов в базу. Это приходится делать, т.к. Jet не считает экселевские файлы полноценным источником данных, не может работать с ними непосредственно через связь, и не может по ним строить индексы и вести нормальный поиск. Может только последовательный перебор от начала до конца файла, что нам совсем не удобно. А вот работа с объектами самого акцесса имеет вполне вменяемое быстродействие. В принципе самое быстрое на данный момент среди файловых баз данных.