Macro help

[austenr]

Here is my problem. I need to create a macro to run the code below. I have never construsted a macro in ACCESS so any help would be appreciated. Thanks in Advance. Screen shots would be appreciated.







Option Compare Database
Option Explicit
'--------------------------------

Function testCompare()
Call CompareTables("DefaultBaseComparisonTable", "empid", "qryBase", "qryVarying")
End Function

'--------------------------------
Sub CompareTables(BaseTable As String, PrimaryKeyField As String, _
BaseTableQuery As String, VaryingTableQuery As String)
'parameters
' BaseTable: the table that is considered the 'base', that is, the one considered accurate
' PrimaryKeyField: the primary key for both tables
' qryBase: an ordered query based on the 'base' table
' qryVarying: an ordered query based on the table being compared to the 'base'

On Error GoTo Err_CompareTables
Dim db As Database
Dim rstBase As Recordset
Dim rstVarying As Recordset
Dim tdf As TableDef
Dim fld As Field
Dim FieldChanged As Boolean
Dim ErrorMessage As String

Set db = CurrentDb

Set rstBase = db.OpenRecordset(BaseTableQuery)
Set rstVarying = db.OpenRecordset(VaryingTableQuery)
Set tdf = db.TableDefs(BaseTable)

db.TableDefs.Delete "TableDiscrepancies"
db.Execute ("CREATE TABLE TableDiscrepancies (CompareErrors TEXT(255));")

rstBase.MoveFirst
rstVarying.MoveFirst

Do Until rstBase.EOF
If rstVarying.EOF = True Then
ErrorMessage = "record " & rstBase(PrimaryKeyField) & _
" deleted fromVarying Table"
db.Execute ("INSERT INTO TableDiscrepancies (CompareErrors) " _
& "VALUES ( '" & ErrorMessage & "');")
rstBase.MoveNext
ElseIf rstBase(PrimaryKeyField) > rstVarying(PrimaryKeyField) Then
ErrorMessage = "record " & rstVarying(PrimaryKeyField) & _
" added to Varying Table"
db.Execute ("INSERT INTO TableDiscrepancies (CompareErrors) " _
& "VALUES ( '" & ErrorMessage & "');")
rstVarying.MoveNext
ElseIf rstBase(PrimaryKeyField) < rstVarying(PrimaryKeyField) Then
ErrorMessage = "record " & rstBase(PrimaryKeyField) & _
" deleted fromVarying Table"
db.Execute ("INSERT INTO TableDiscrepancies (CompareErrors) " _
& "VALUES ( '" & ErrorMessage & "');")
rstBase.MoveNext
Else
For Each fld In tdf.Fields
If rstBase(fld.Name) <> rstVarying(fld.Name) Then
ErrorMessage = "Record: " & rstBase(PrimaryKeyField) & _
" field: " & fld.Name & _
" has changed from " & rstBase(fld.Name) & _
" to " & rstVarying(fld.Name)
db.Execute ("INSERT INTO TableDiscrepancies (CompareErrors)" _
& " VALUES ( '" & ErrorMessage & "');")
FieldChanged = True
End If
Next fld
If Not FieldChanged Then
ErrorMessage = "Record " & rstBase(PrimaryKeyField) & _
" identical"
End If
rstBase.MoveNext
rstVarying.MoveNext
FieldChanged = False
End If
Loop
Do Until rstVarying.EOF
ErrorMessage = "record " & rstVarying(PrimaryKeyField) & _
" added to Varying Table"
db.Execute ("INSERT INTO TableDiscrepancies (CompareErrors) " _
& "VALUES ( '" & ErrorMessage & "');")
rstVarying.MoveNext
Loop

Exit_CompareTables:
Set rstBase = Nothing
Set rstVarying = Nothing
db.Close
Exit Sub
Err_CompareTables:
If Err.Number = 3010 Then '*** if the error is the table is missing
Resume Next '*** then skip the delete line and resume on the next line
ElseIf Err.Number = 3265 Then
Resume Next
Else
MsgBox Err.Description '*** write out the error and exit the sub
Resume Exit_CompareTables
End If
End Sub

 

[Norie]

create a macro to run the code below.

I'm not quite sure what you mean.

If you definetely want to create a macro to run the code goto the Macros tab in Access, select New and from the Action dropdown select RunCode and then enter the name of the function below.

If you just want to run the posted code open it in design view and hit F5.