Vba

Синтаксис:

Application.Match(<что ищем>, <где ищем>, <как ищем>)

<Что ищем> может быть:

• одно значение - переменная или константа, например «aaa», 123 или ValueToFind, причем различных типов - строка, число, дата, логическое.

  • текстовые значения могут содержать подстановочные знаки * (0+ любых символов),? (один любой символ). Их можно экранировать тильдой ~, если нужно найти именно * или ?

• одномерный массив Array(«aaa», 123)

• диапазон листа Excel (строка или столбец) Range("A1:A10"), Range("A1:F1")

<Где ищем> может быть:

• одномерный массив, содержащий значения различных типов, например, Array(«aaa», 123)

• диапазон листа Excel (строка или столбец) Range("A1:A10"), Range("A1:F1")

<Как ищем>:

• 0 - точно. Массив <Где ищем> может быть неупорядоченным (неотсортированным)

• -1 - поиск наименьшего значения. Массив <Где ищем> должен быть отсортирован по убыванию

• 1 - поиск наибольшего значения. Массив <Где ищем> должен быть отсортирован по возрастанию

Application.Match() возвращает:

• если <что ищем> – одно значение, то возвращается одно значение типа Double (индекс найденного значения в массиве, начиная с 1) или значение типа Error (если значение не найдено);

• если <что ищем> – массив из N элементов, то возвращается массив, содержащий N значений типа Double (индекс найденного значения в массиве, начиная с 1) или значений типа Error (если значение не найдено).

Особенности:

• если значение не найдено, возвращается значение ошибки #N/A [Error 2042] (метод WorksheetFunction.Match() в этом случае генерирует исключение)

• поиск текста производится всегда регистронезависимо, т.е. прописные и строчные буквы А и а считаются одинаковыми, и не зависит от установки Option Compare { Binary | Text }

• при успешном поиске Application.Match() возвращает для каждого искомого значения только первый индекс найденного элемента в <где ищем>. Т.е. если <что ищем> = 2,2 а в <где ищем> находится 2,1,2,2, то результатом будет массив 1,1 - обе двойки найдется в первом индексе.

• Индексы нумеруются с 1 независимо от установки Option Base { 0 | 1 }.

Примеры применения Application.Match()

1. Ищем несколько текстов, в т.ч. по маске, в массиве:

Данный код ищет строки «qqq» (три q или Q подряд) и «a?b» (строка из трех символов, начинающаяся на a или A, заканчивающаяся на b или B с любым символом посередине) в массиве arr, содержащем строки «AAA», «A5A», «Abb».

В результате работы кода в окне Immediate будет напечатано:

Этот результат означает, что строка "qqq" не найдена в массиве arr, а "a?b" соответствует третьему элементу "Abb".

2. Ищем значения из столбца A в столбце C:

Этот код ищет значения из ячеек колонки A листа Excel в колонке C листа Excel. Результат выводится в цикле с предварительной проверкой, найден ли очередной элемент или нет. Эта проверка производится с помощью функции IsNumeric(), которая возвращает Истину в том случае, если аргумент - число. В том случае, если значение не найдено, в результирующем массиве будет находиться значение ошибки (Error), и IsNumeric() вернет Ложь. Также это можно проверить с помощью функции IsError(), которая возвращает Истину, если аргумент является значением ошибки.

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

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 не считает экселевские файлы полноценным источником данных, не может работать с ними непосредственно через связь, и не может по ним строить индексы и вести нормальный поиск. Может только последовательный перебор от начала до конца файла, что нам совсем не удобно. А вот работа с объектами самого акцесса имеет вполне вменяемое быстродействие. В принципе самое быстрое на данный момент среди файловых баз данных.

strSearch = InputBox("String to search:", "Search a string", "")

If strSearch = "" Then

Exit Sub

End If

Set wOut = Worksheets.Add

lRow = 1

With wOut

.Cells(lRow, 1) = "Workbook"

.Cells(lRow, 2) = "Worksheet"

.Cells(lRow, 3) = "Cell"

.Cells(lRow, 4) = "Text in Cell"

Set fso = CreateObject("Scripting.FileSystemObject")

Set fld = fso.GetFolder(strPath)

strFile = Dir(strPath & "\*.xls*")

Do While strFile <> ""

Set wbk = Workbooks.Open _

(Filename:=strPath & "\" & strFile, _

UpdateLinks:=0, _

ReadOnly:=True, _

AddToMRU:=False)

For Each wks In wbk.Worksheets

Set rFound = wks.UsedRange.Find(strSearch)

If Not rFound Is Nothing Then

strFirstAddress = rFound.Address

End If

Do

If rFound Is Nothing Then

Exit Do

Else

lRow = lRow + 1

.Cells(lRow, 1) = wbk.Name

.Cells(lRow, 2) = wks.Name

.Cells(lRow, 3) = rFound.Address

.Cells(lRow, 4) = rFound.Value

End If

Set rFound = wks.Cells.FindNext(After:=rFound)

Loop While strFirstAddress <> rFound.Address

Next

wbk.Close (False)

strFile = Dir

Loop

.Columns("A:D").EntireColumn.AutoFit

End With

MsgBox "Done"

ExitHandler:

Set wOut = Nothing

Set wks = Nothing

Set wbk = Nothing

Set fld = Nothing

Set fso = Nothing

Application.ScreenUpdating = True

Exit Sub

ErrHandler:

MsgBox Err.Description, vbExclamation

Resume ExitHandler

End Sub

' для использования вам нужно поменять strPath = "C:\Components" на ваш адрес папки