Check Access table(s) from Excel using Automation – Updated Code

Here is the revised and completed code that I posted yesterday. The DAO declarations are moved outside the Sub procedure and the 'Set' statements are outside the function loop. Also, the table & column headers are now passed as arguments to the function, making the code more compact. The speed increase over yesterday's code is significant.

Option Explicit
Dim DAODB As DAO.Database
Dim DAORS As DAO.Recordset
Dim objDBEngine As DAO.DBEngine
Dim objWSP As DAO.Workspace

Sub DDFileReconcile
' Macro to search Access db "dB" for values in an Excel worksheet
' Values/text should be in column B, starting in cell B2, result of search is placed in H2
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


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

  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"
      cell.Offset(0, 6).Value = "Not Found"
    End If
  Next cell
  MsgBox ("Database file appears to be locked. Please try again later."), vbCritical
  GoTo ExitProc
End If

Set objDBEngine = Nothing
Set objWSP = Nothing
Set DAODB = Nothing
Set DAORS = 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)
DAORS.Index = ColToSearch
DAORS.Seek "=", cell

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

End Function


About JP

I'm just an average guy who writes VBA code for a living. This is my personal blog. Excel and Outlook are my thing, with a sprinkle of Access and Word here and there. Follow this space to learn more about VBA. Keep Reading »

Share This Article:

Share and bookmark this articledelicious buttonfacebook buttonlinkedin buttonstumbleupon buttontwitter button

This article is closed to any future comments.
excel school learn dashboards