Using Excel to check Access db for matching record

[JP]

Greetings,

I have list of order numbers in Excel 2003 which I would like to
search for in an Access 2003 database. The db has three tables; I am
writing a routine that would check each table and, if it finds the
order number, make a note in the spreadsheet and move on to the next
row.

To avoid overhead I'd like to do this without physically opening the
db (if possible).

Normally I code in Excel/Outlook so the Access jargon is unfamiliar.
Are there any websites that cover this topic so I could locate the
appropriate code and syntax?


Thx,
JP

 

[GeoffG]

Here's some sample code you can adapt.
Regards
Geoff


Option Explicit

' Code for standard module in Excel Workbook.

' This project requires a reference to Microsoft DAO 3.6.
' To set reference, in VBA editor, open the Tools menu,
' select References, and select Microsoft DAO 3.6.

' Excel Constants:
Private Const mstrcWorksheet1 As String = "Sheet1"
Private Const mlngcOrderNoColNo As Long = 1
Private Const mlngcTable1ResultColNo As Long = 2
Private Const mlngcTable2ResultColNo As Long = 3
Private Const mlngcTable3ResultColNo As Long = 4

' Access Constants:
Private Const mstrcDBPathName As String = "C:\db1.mdb"

Private Const mstrcTable1Name As String = "Table1"
' Name of index on OrderNo field in Table1:
Private Const mstrcIndex1 As String = "OrderNo"

Private Const mstrcTable2Name As String = "Table2"
' Name of index on OrderNo field in Table2:
Private Const mstrcIndex2 As String = "OrderNo"

Private Const mstrcTable3Name As String = "Table3"
' Name of index on OrderNo field in Table3:
Private Const mstrcIndex3 As String = "OrderNo"

' Excel Objects:
Private mobjWBK As Excel.Workbook
Private mobjWSH As Excel.Worksheet
Private mobjXLRng As Excel.Range
Private mobjXLOrderNo As Excel.Range
Private mobjXLResult As Excel.Range

' Excel working variable:
Private mlngXLOrderNo As Long

' DAO objects:
Private mobjDBEngine As DAO.DBEngine
Private mobjWSP As DAO.Workspace
Private mobjDB As DAO.Database
Private mobjTBL As DAO.TableDef
Private mobjRS As DAO.Recordset


Private Sub CheckAccessTables()

Dim fStart As VbMsgBoxResult
Dim cintTableNo As Integer
Dim astrTableNames(1 To 3) As String
Dim astrIndexNames(1 To 3) As String
Dim alngResultCols(1 To 3) As Long
Dim lngRowNo As Long
Dim lngResultColNo As Long
Dim fFound As Boolean

On Error GoTo Error_CheckAccessTables

' See if OK to start:
fStart = MsgBox("Start?", vbYesNoCancel + vbDefaultButton2, _
"Program Start")
If fStart <> vbYes Then
GoTo Exit_CheckAccessTables
End If

' Initialise Excel objects:
Set mobjWBK = Excel.ActiveWorkbook
Set mobjWSH = mobjWBK.Worksheets(mstrcWorksheet1)
Set mobjXLRng = mobjWSH.Cells(1, 1)
Set mobjXLRng = mobjXLRng.CurrentRegion
Debug.Print mobjXLRng.Address

' Initialise DAO objects:
Set mobjDBEngine = New DAO.DBEngine
Set mobjWSP = mobjDBEngine.Workspaces(0)
Set mobjDB = mobjWSP.OpenDatabase(mstrcDBPathName)

' Load table names:
astrTableNames(1) = mstrcTable1Name
astrTableNames(2) = mstrcTable2Name
astrTableNames(3) = mstrcTable3Name

' Load index names:
astrIndexNames(1) = mstrcIndex1
astrIndexNames(2) = mstrcIndex2
astrIndexNames(3) = mstrcIndex3

' Load result column numbers:
alngResultCols(1) = mlngcTable1ResultColNo
alngResultCols(2) = mlngcTable2ResultColNo
alngResultCols(3) = mlngcTable3ResultColNo

' Loop through Excel rows:
For lngRowNo = 2 To mobjXLRng.Rows.Count
GoSub DoNextExcelRow
Next

MsgBox "Finished", vbOKOnly + vbInformation, "Program Finished"

Exit_CheckAccessTables:

GoSub CleanUp
Exit Sub

DoNextExcelRow:

' Get Order number from current Excel row:
Set mobjXLOrderNo = mobjXLRng.Cells(lngRowNo, mlngcOrderNoColNo)
mlngXLOrderNo = mobjXLOrderNo.Value
Debug.Print "Excel Order No = " & CStr(mlngXLOrderNo)

' Loop through Access tables:
For cintTableNo = 1 To 3
GoSub DoNextTable
Next

Return

DoNextTable:

' Point to Excel cell where result is to be written
' and clear it:
Set mobjXLResult = _
mobjXLRng.Cells(lngRowNo, alngResultCols(cintTableNo))
mobjXLResult.Clear

' Point to table, open recordset and set index so
' we can use the fast Seek method (assumes the
' index only indexes the Order No field):
Set mobjTBL = mobjDB.TableDefs(astrTableNames(cintTableNo))
Set mobjRS = mobjTBL.OpenRecordset(dbOpenTable)
mobjRS.Index = astrIndexNames(cintTableNo)
mobjRS.Seek "=", mlngXLOrderNo

' See if Order No was found in Access table:
fFound = (mobjRS.NoMatch = False)

' Write back to Excel if found:
If fFound Then

' Write result to Excel cell:
mobjXLResult.Value = "Found"

End If

Return

CleanUp:

' Excel objects:
Set mobjXLResult = Nothing
Set mobjXLOrderNo = Nothing
Set mobjXLRng = Nothing
Set mobjWSH = Nothing
Set mobjWBK = Nothing

' DAO objects:
If Not mobjRS Is Nothing Then
mobjRS.Close
Set mobjRS = Nothing
End If
Set mobjTBL = Nothing
If Not mobjDB Is Nothing Then
mobjDB.Close
Set mobjDB = Nothing
End If
Set mobjWSP = Nothing
Set mobjDBEngine = Nothing

Return

Error_CheckAccessTables:

MsgBox Err.Description, vbOKOnly + vbExclamation, _
"Error No: " & CStr(Err.Number)
Resume Exit_CheckAccessTables

End Sub

 

[JP]

Thanks Geoff, works like a charm!

I discovered that the field has to be Indexed first, so I did that
manually on each table I want to check. Here's the (almost final)
code:


Sub DDFileReconcile()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

If Dir("C:\dB.ldb") = "" Then
Dim CheckRng As Excel.Range
Dim cell As Excel.Range

ActiveSheet.UsedRange

Set CheckRng = Range("B2", Range("B65536").End(xlUp))

For Each cell In CheckRng

If MatchAccessTables(cell.Value) Then
cell.Offset(0, 6).Value = "Found"
Else
cell.Offset(0, 6).Value = "Not Found"
End If

Next cell

Else
MsgBox ("Database file appears to be locked. Please try again
later."), vbCritical
Exit Sub
End If

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Function MatchAccessTables(cell As String) As Boolean

MatchAccessTables = False

Dim DAODB As DAO.Database
Dim DAORS As DAO.Recordset
Dim DAOTBL As DAO.TableDef
Dim objDBEngine As DAO.DBEngine
Dim objWSP As DAO.Workspace

Set objDBEngine = New DAO.DBEngine
Set objWSP = objDBEngine.Workspaces(0)
Set DAODB = objWSP.OpenDatabase("C:\dB.mdb")

Set DAORS = DAODB.OpenRecordset("table1", dbOpenTable)

Set DAOTBL = DAODB.TableDefs("table1")
Set DAORS = DAOTBL.OpenRecordset(dbOpenTable)
DAORS.Index = "Column Header"
DAORS.Seek "=", cell

If DAORS.NoMatch = False Then
MatchAccessTables = True
End If

End Function


Thx,
JP

 

[GeoffG]

I didn't mention it yesterday and this may not apply in your application
but, after opening a recordset, you should test to see if it's empty. If
you don't test and an Access table is empty, you'll get a runtime error.

You can test for an empty recordset using the BOF (Beginning of File) and
EOF (End of File) properties of the recordset. If both properties are True,
then the recordset is empty. Here's a suggestion:

Set DAORS = DAOTBL.OpenRecordset(dbOpenTable)
If DAORS.BOF And DAORS.EOF Then
' The recordset is empty - take appropriate action.
' Don't use recordset beyond this point.
End If

You're right, the field has to be indexed if you use the Seek method. The
Seek method also needs a Table-type recordset (as specified by the
dbOpenTable constant).

I'm not sure you need any further comments, but I'd just mention two things:

1. It seems you don't need the OpenRecordset method twice, the first time
on the database object and the second time on the table object, as in your
code:

Set DAORS = DAODB.OpenRecordset("table1", dbOpenTable)
Set DAOTBL = DAODB.TableDefs("table1")
Set DAORS = DAOTBL.OpenRecordset(dbOpenTable)

2. You're creating and destroying all the DAO objects for each cell. I
don't know enough about what goes on under the hood to know if this matters
too much, but I'd be inclined to declare the DAO variables with module-wide
scope and instantiate and destroy them once.

It's good to see how an Excel programmer deals with cell manipulation.

Regards
Geoff


Thanks Geoff, works like a charm!

I discovered that the field has to be Indexed first, so I did that
manually on each table I want to check. Here's the (almost final)
code:


Sub DDFileReconcile()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

If Dir("C:\dB.ldb") = "" Then
Dim CheckRng As Excel.Range
Dim cell As Excel.Range

ActiveSheet.UsedRange

Set CheckRng = Range("B2", Range("B65536").End(xlUp))

For Each cell In CheckRng

If MatchAccessTables(cell.Value) Then
cell.Offset(0, 6).Value = "Found"
Else
cell.Offset(0, 6).Value = "Not Found"
End If

Next cell

Else
MsgBox ("Database file appears to be locked. Please try again
later."), vbCritical
Exit Sub
End If

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Function MatchAccessTables(cell As String) As Boolean

MatchAccessTables = False

Dim DAODB As DAO.Database
Dim DAORS As DAO.Recordset
Dim DAOTBL As DAO.TableDef
Dim objDBEngine As DAO.DBEngine
Dim objWSP As DAO.Workspace

Set objDBEngine = New DAO.DBEngine
Set objWSP = objDBEngine.Workspaces(0)
Set DAODB = objWSP.OpenDatabase("C:\dB.mdb")

Set DAORS = DAODB.OpenRecordset("table1", dbOpenTable)

Set DAOTBL = DAODB.TableDefs("table1")
Set DAORS = DAOTBL.OpenRecordset(dbOpenTable)
DAORS.Index = "Column Header"
DAORS.Seek "=", cell

If DAORS.NoMatch = False Then
MatchAccessTables = True
End If

End Function


Thx,
JP

 

[JP]

Good points, I moved the declarations to the top of the module and the
"Set" statements outside of the loop. Now I just pass the arguments to
the function which also makes the code more compact. The speed
increase is significant.

FYI there is no need to check BOF/EOF, these are known databases with
10k+ records each so no worries about being empty.

Here is the revised and completed code (scrubbed of course to protect
the innocent).

Option Explicit
Dim DAODB As DAO.Database
Dim DAORS As DAO.Recordset
Dim DAOTBL As DAO.TableDef
Dim objDBEngine As DAO.DBEngine
Dim objWSP As DAO.Workspace
Sub DDFileReconcile()
'
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

If Dir("C:\dB.ldb") = "" Then
' If a .mdb file is open, a matching .ldb file with the same name is
opened in the same directory
Dim CheckRng As Excel.Range
Dim cell As Excel.Range

ActiveSheet.UsedRange

Set CheckRng = Range("B2", Range("B65536").End(xlUp))
Set objDBEngine = New DAO.DBEngine
Set objWSP = objDBEngine.Workspaces(0)
Set DAODB = objWSP.OpenDatabase("C:\dB.mdb")

For Each cell In CheckRng

If MatchAccessTables(cell.Value, "table 1", "Indexed Column
Header 1") Then
cell.Offset(0, 6).Value = "Found"
ElseIf MatchAccessTables(cell.Value, "table 2", " Indexed
Column Header 2") Then
cell.Offset(0, 6).Value = "Found"
ElseIf MatchAccessTables(cell.Value, "table 3", " Indexed
Column Header 3") Then
cell.Offset(0, 6).Value = "Found"
Else
cell.Offset(0, 6).Value = "Not Found"
End If

Next cell

Else
MsgBox ("Database file appears to be locked. Please try again
later."), vbCritical
GoTo ExitProc
End If

ExitProc:
Set objDBEngine = Nothing
Set objWSP = Nothing
Set DAODB = Nothing
Set DAORS = Nothing
Set DAOTBL = Nothing
Set CheckRng = Nothing
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Function MatchAccessTables(cell As String, TableName As String,
ColToSearch As String) As Boolean

MatchAccessTables = False

Set DAORS = DAODB.OpenRecordset(TableName, dbOpenTable)
Set DAOTBL = DAODB.TableDefs(TableName)
DAORS.Index = ColToSearch
DAORS.Seek "=", cell

If DAORS.NoMatch = False Then
MatchAccessTables = True
End If

End Function


Thx,
JP

 

[GeoffG]

The speed increase is significant.

You may get even better performance if you use three recordset objects (see
below).

Regards
Geoff



Option Explicit

Private objDBEngine As DAO.DBEngine
Private objWSP As DAO.Workspace
Private DAODB As DAO.Database
Private DAORS1 As DAO.Recordset
Private DAORS2 As DAO.Recordset
Private DAORS3 As DAO.Recordset
' Not needed:
'Private DAOTBL As DAO.TableDef


Sub DDFileReconcile()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

If Dir("C:\dB.ldb") = "" Then

' If a .mdb file is open, a matching .ldb file
' with the same name is opened in the same directory.

Dim CheckRng As Excel.Range
Dim cell As Excel.Range

ActiveSheet.UsedRange

Set CheckRng = Range("B2", Range("B65536").End(xlUp))
Set objDBEngine = New DAO.DBEngine
Set objWSP = objDBEngine.Workspaces(0)
Set DAODB = objWSP.OpenDatabase("C:\dB.mdb")

' Open a recordset on table 1:
Set DAORS1 = DAODB.OpenRecordset("table 1", dbOpenTable)
DAORS1.Index = "Indexed Column Header 1"

' Open a recordset on table 2:
Set DAORS2 = DAODB.OpenRecordset("table 2", dbOpenTable)
DAORS2.Index = "Indexed Column Header 2"

' Open a recordset on table 3:
Set DAORS3 = DAODB.OpenRecordset("table 3", dbOpenTable)
DAORS3.Index = "Indexed Column Header 3"

' Now simply pass each cell to a subprocedure and
' let it do all the work:
For Each cell In CheckRng
Call MatchAccessTables(cell)
Next cell

Else
MsgBox ("Database file appears to be locked. " _
& "Please try again later."), vbCritical, _
"Program Finished"
GoTo ExitProc
End If

ExitProc:

' I tend to destroy in reverse order of creation,
' closing the recordsets and database:
If Not (DAORS1 Is Nothing) Then
DAORS1.Close
Set DAORS1 = Nothing
End If
If Not (DAORS2 Is Nothing) Then
DAORS2.Close
Set DAORS2 = Nothing
End If
If Not (DAORS3 Is Nothing) Then
DAORS3.Close
Set DAORS3 = Nothing
End If
If Not (DAODB Is Nothing) Then
DAODB.Close
Set DAODB = Nothing
End If
' Not needed:
' Set DAOTBL = Nothing
Set objWSP = Nothing
Set objDBEngine = Nothing

Set CheckRng = Nothing
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Private Sub MatchAccessTables(cell As Excel.Range)

' Search in recordset on table 1:
DAORS1.Seek "=", cell.Value
If DAORS1.NoMatch = False Then
cell.Offset(0, 6).Value = "Found"
GoTo Exit_MatchAccessTables
End If

' Search in recordset on table 2:
DAORS2.Seek "=", cell.Value
If DAORS2.NoMatch = False Then
cell.Offset(0, 6).Value = "Found"
GoTo Exit_MatchAccessTables
End If

DAORS3.Seek "=", cell.Value
If DAORS3.NoMatch = False Then
cell.Offset(0, 6).Value = "Found"
GoTo Exit_MatchAccessTables
End If

' If we're here, we've not found it:
cell.Offset(0, 6).Value = "Not Found"

Exit_MatchAccessTables:

Exit Sub

End Sub

 

[JP]

I'll consider it, but at this point it is averaging .625 seconds on a
spreadsheet with 2k rows. This is the usual amount of data I'm
checking so speed is no longer a concern.

Thanks again for all your help.

--JP

 

[GeoffG]

Thanks for posting back with timings. It's extraordinary how fast the
creation of a recordset can be. In my tests, for 2k rows in Excel and 10k
records in Access, your code executed in 219 milliseconds and mine in 125
milliseconds. In other words, it took your code less than a tenth of a
second extra to open the recordset 2k times. That is remarkable, given the
creation of some 20M, as opposed to some 6k bookmarks. However, as you
indicate, it's insignificant in practice.

Thanks for the feedback and glad you're home and dry.
Regards
Geoff




I'll consider it, but at this point it is averaging .625 seconds on a
spreadsheet with 2k rows. This is the usual amount of data I'm
checking so speed is no longer a concern.

Thanks again for all your help.

--JP