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

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.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"
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 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

Enjoy,
JP

---

Check Access table(s) from Excel using Automation

Finally, with some help from the good folks over in the microsoft.public.access.modulesdaovba newsgroup, I was able to complete my code to search an Access database for some information stored in an Excel worksheet.

This code will cycle through a list of numbers in column B, starting in cell B2, then check three tables in an Access file for a matching record. If it finds a match in the first table, it exits, otherwise it checks the second, then the third table (no need to keep going if we find a match right away). It prints "Found" or "Not Found", as appropriate, in the corresponding cell in column H. This is to accomodate my specific needs for this project at my office, but you could easily adjust this code to search for text or numbers in the Access db of your choice and put the response into the next column (instead of 6 columns away).

I got a pretty rough education in Access VBA coding; it took only a few minutes to write the code, but hours to search for the proper syntax to access the correct objects.

First you need to open each table and index the column you want to search. This is the "Column Header #" that contains the values you want to search through. Click on the table and go to 'Design View'. Select the field you want to index, and in the box at the bottom, click in the dropdown next to 'Index' and choose 'Yes (duplicates OK)'. Save and close and now you can use the Index property of the Recordset Object to specify that column to search for your values.

Sub FileCheck()
'
' Macro to search a column in an Access db table for text/values in column B, starting in cell B2
'
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

If Dir("C:\Folder\database.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))

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
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) 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:\Folder\database.mdb ")

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

If DAORS.NoMatch = False Then
MatchAccessTables = True
Exit Function
Else
Set DAORS = DAODB.OpenRecordset("Table 2", dbOpenTable)
Set DAOTBL = DAODB.TableDefs("Table 2")
Set DAORS = DAOTBL.OpenRecordset(dbOpenTable)
DAORS.Index = "Column Header 2"
DAORS.Seek "=", cell
End If

If DAORS.NoMatch = False Then
MatchAccessTables = True
Exit Function
Else
Set DAORS = DAODB.OpenRecordset("Table 3", dbOpenTable)
Set DAOTBL = DAODB.TableDefs("Table 3")
Set DAORS = DAOTBL.OpenRecordset(dbOpenTable)
DAORS.Index = "Column Header 3"
DAORS.Seek "=", cell
End If

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

End Function


Make sure you set a reference to 'Microsoft DAO 3.6 Object Library' before using this code.

Enjoy,
JP

Acknowledgments: microsoft.public.access.modulesdaovba

---

Counting Unique Occurrences in an Excel Spreadsheet

This formula, entered as an array (Ctrl-Shift-Enter) in a single cell, will show you if there any duplicate entries in a given range (in this case, A1:C100). It is wrapped in an IF function to provide a friendly message; a kind of in-cell error handling, if you will. I usually do this when I know others are going to use the formula, to make it easy for them to understand the output. Otherwise it just gives you the number of unique entries which some people may not know what to do with.


=IF(COUNTA(A1:C100)=SUM(1/COUNTIF(A1:C100,A1:C100)),"No duplicates","Some duplicates")


The formula first counts the number of used cells in the range (COUNTA function). Then compares it to the array portion of the formula which counts unique entries (from http://support.microsoft.com/kb/823573).


The range must not contain blanks. If it does, you get a #DIV/0! error. If you are working with a range that contains blanks, or if you are giving out the formula to others, use this instead:


=IF(COUNTA(A1:C100)=SUM(IF(LEN(A1:C100),1/COUNTIF(A1:C100,A1:C100))),"NO duplicates","Some duplicates")

That way when someone creates a blank in the range, they won't come running to you to see why the formula is broken. :-)

You could also give a count of the number of duplicates, but I discourage this as it slows down the workbook considerably, since you are checking the array twice:

=IF(COUNTA(A1:C100)=SUM(IF(LEN(A1:C100),1/COUNTIF(A1:C100,A1:C100))),"No duplicates",COUNTA(A1:C100)-SUM(IF(LEN(A1:C100),1/COUNTIF(A1:C100,A1:C100))) &" duplicates")

--JP

---

Advanced Topics In Excel Training Class

My offer to teach Excel training classes at my office has been accepted. The class is tentatively titled "Advanced Topics in Excel" and will cover the following topics (among others TBD). I will also be including code and formulas from this site.

Counting/Filtering:
SUMPRODUCT, COUNTIF, SUMIF
Working with dates:
INT/MOD
Text functions:
RIGHT, LEFT, MID
Misc functions:
HYPERLINK
And of course, Macros.

The class will debut sometime after March. So far I have been spending about 4 hours per day (straight) writing course material. There will also be an Outlook training class for which I will also write the curriculum.

I swore never to write tutorials, but I will post the class material to the site once it is completed.

TTFN,
JP

---

Formatting Zip+4 Codes

If you have a column of zip+4, this macro will remove the suffix. Simply highlight the cells in question. It will skip any zip codes that don't have the suffix. It uses the Left$ string function which is more efficient than the standard Left() and always returns the first 5 characters in the cell.

Sub Convert_ZipCode_Fix_ZIP_plus4()
Dim cell As Excel.Range

With WorksheetFunction
For Each cell In Selection
' cell = .Trim(cell) ' optional
If Len(cell) > 5 Then
cell = Left$(cell, Len(cell) - (Len(cell) - 5))
End If
Next cell
End With
End Sub

Enjoy,
JP

---

Formula for Date/Time Subtraction in Excel

This formula will show the difference (in hours) between two cells with date/time values.

=IF(INT(B2)-INT(A2)<1,24*(mod(b2,1)-mod(a2,1)),((int(b2)-int(a2))*24)+24*(mod(b2,1)-mod(a2,1)))

Press Ctrl-1 to format the cell, on the Number tab choose "Custom," enter this format:

####.0# "hours"

The cell will show the number of hours passed between both dates/times, neatly formatted with a custom format displaying the word "hours" in the cell.

For example, suppose you have "1/12/2008 10:30 AM" in cell A2 and "1/13/08 11:00 AM" in cell B2 in the same worksheet. The formula cell will display "24.5 hours". You can display the cells in any format you wish (i.e. General, Date, etc), as long as they contain real dates/times.

The time value is in decimal format based on hours, so .5 hours = 30 minutes and .75 hours is 45 minutes.


Enjoy,
JP

---

Outlook VBA Code to Check Mail Size

This code, run on the currently open mail item, will display a message box giving you the size of the email in kilobytes.

Sub CheckMailSize()
Dim CurrentMsg As Outlook.MailItem
On Error Resume Next
Set CurrentMsg = ActiveInspector.CurrentItem
On Error Goto 0

If (CurrentMsg Is Nothing) Or (TypeName(CurrentMsg) <> "MailItem") Then
MsgBox "Double-click on a message first."
Exit Sub
End If

MsgBox "This message is " & CurrentMsg.Size & " kb."
Set CurrentMsg = Nothing
End Sub

And here is an application-level event handler that does the same thing (if you don't mind being interrupted every time you hit 'Send'):

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
If TypeName(Item) = "MailItem" Then
Dim Msg As Outlook.MailItem
Set Msg = Item

MsgBox "This message is " & Msg.Size & " kb."
Set Msg = Nothing
End If

Apologies in advance for the lack of indentation.

Enjoy,
JP

---

MS KB Articles added to VBA Search Engine

I added a lot of KB articles to the custom search engine, it is now 200 sites! Try it out and let me know how it works.

http://www.codeforexcelandoutlook/searchbox.html


Take care,
JP

---

My first Access macro

I wrote my first Access macro today! Now, I am not a big fan of Access, but unfortunately I have to use it at work because it is the first choice for most people looking for a db (short for "database") program. For most situations, I prefer Excel.

At work I have to import data from Excel to Access. Being as lazy as I am, I always try to find an easy way to do things. Otherwise I have to do it manually three times a day, and we can't have that, can we? Since we are referring to MS Office programs, my first choice is VBA. So I found an Access function that automates importing XL spreadsheets. Here is the syntax:

DoCmd.TransferSpreadsheet (TransferType, SpreadsheetType, TableName, FileName, HasFieldNames, Range, UseOA)

For my purposes, the code is:

DoCmd.TransferSpreadsheet acImport, , "table name", "C:\Filename.xls", True

My .xls files always have headers so the 'HasFieldNames' argument is 'True'.

Now my next task is to create a macro in Excel to pull the spreadsheet from Outlook, format it, then start an instance of Access (always with early binding, of course) and import the spreadsheet! Once that is done I will post the code on the regular site (with the data scrubbed to protect the innocent).


TTFN,
JP


Acknowledgements:
http://msdn2.microsoft.com/en-us/library/aa220766(office.11).aspx
http://www.mvps.org/access/general/gen0008.htm

---

My first blog!

Hello.

That's it?

Well, it's my first blog and my first post to my first blog. So it will be a bit boring. What I can promise you is that this website will only continue to grow with more code samples, formulas, links and other goodies. Eventually I would like to build a forum/posting area. If you have any thoughts, let me know.

Talk soon,
JP

---