закомменте временно строку On Error Resume Next
она мешает вам видеть текст ошибки

8000 раз выполняется запрос, может изменить методику расчета

конечно весьма смахивает на некое подобие стат-отчета

и конечно вы уверены, что значение DBRS![Поле Б] обязательно имеется, так как не проверяете на null
Cells(WorkRow, 2) = DBRS![Поле Б]

Buzzo,

и я видимо заполняла бы рабочую аксесс таблицу, а затем только сбрасывала в ексель

супер много - явно надо менять методику расчета
ведь выбирается одна строка

если более - ошибка в исходной таблице
если не найдено - что же, бывает, но надо обрабатывать эту ситуацию

Buzzo,
видимо ускорение будет раз в 10 если переставить пару строк
Option Base 1

Sub Add_From_MS()

Dim DBRS As ADODB.Recordset
Dim DBQuery As String
Dim DBConnect As String
Dim WorkRow, WorkRowArr, SearchArr

On Error Resume Next

SearchArr = Range(Cells(2, 1), Cells(8000, 1))

DBConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source = C:\DB.accdb"
''''''''''''''''''
Set DBRS = New ADODB.Recordset
''''''''''''''''''
For WorkRow = 2 To 8000

WorkRowArr = WorkRow - 1

DBQuery = "SELECT * FROM Table" & Left(SearchArr(WorkRowArr, 1), 2) & " WHERE [Поле А]='" & SearchArr(WorkRowArr, 1) & "'"


DBRS.Open DBQuery, DBConnect, adOpenStatic, adLockReadOnly

Cells(WorkRow, 2) = DBRS![Поле Б]

DBRS.Close

Next
'''''''''''''''''''''''''
Set DBRS = Nothing


End Sub