AMTSelect is a declared variable variant type for the Getrows array
rCount is an integer
I'm trying to pull the first field value from each row but I keep getting an error saying that the subscript is out of range. The error happens in the for loop.
Code is below:
If Contractnum <> "" Then
CNTRecords = "Select Count(*) from [Manual_AINs] WHERE [Manual_AINs].[Contract_Number]= '" & Contractnum & "';"
Set rs = CurrentDb.OpenRecordset(CNTRecords)
rCount = rs.Fields(0)
Set rs = Nothing
If rCount > 1 Then
qAMT = "Select [Dollar Amount] from [Manual_AINs] WHERE ((([Manual_AINs].[Contract_Number])='" & Contractnum & "'));"
Set rs = CurrentDb.OpenRecordset(qAMT)
AMTSelect = rs.GetRows
AMTSelectString = "Choose appropriate dollar amount of AIN from the selection below:" & Chr(10) & Chr(10)
For i = 1 To rCount
AMTSelectString = AMTSelectString & i & ".) " & Format(AMTSelect(0, (i - 1)), "$#,##0.00") & Chr(10)
Next i
You aren't requesting any rows with .GetRows - this is basically just calling .GetRows(0), which won't return any rows into your Recordset.
Change this line...
AMTSelect = rs.GetRows
...to:
AMTSelect = rs.GetRows(rCount)
That said, since you are apparently trying to use every line in the Recordset, this is much simpler:
If Contractnum <> "" Then
qAMT = "Select [Dollar_Amount] from [Manual_AINs] WHERE [Manual_AINs].[Contract_Number]='" & Contractnum & "';"
With CurrentDb.OpenRecordset(qAMT)
If Not .EOF Then .MoveFirst
AMTSelectString = "Choose appropriate dollar amount of AIN from the selection below:" & Chr(10) & Chr(10)
Dim i As Long
Do While Not .EOF
i = i + 1
AMTSelectString = AMTSelectString & i & ".) " & Format$(.Fields(0), "$#,##0.00") & Chr(10)
.MoveNext
Loop
End With
End If
Related
This query is used to call a specific set of work requests over a period of time, this query takes date inputs and the system number from a form. The query result is then put into another form to view.
I've gone over all VBA code that is relevant to this and there seems to be no problems there however so I have determined that the query is too complex and as I am not too well versed in SQL I am not too sure where to go from here.
This Query also provides a #name? Error viewed in forms
The Query
SELECT tbl_NIMSD_dbo_TIDWRREQ.WO_REQ_NUMBER
,tbl_NIMSD_dbo_TIDWRREQ.WR_TASK_TITLE
,"Click Here" AS [Work Request Description]
,tbl_NIMSD_dbo_TIDWRREQ.SYSTEM_CODE
,tbl_NIMSD_dbo_TIDWRREQ.UNIT
,[tbl_NIMSD_dbo_TIDWRREQ].[Unit] + "-" + [tbl_NIMSD_dbo_TIDWRREQ].[SYSTEM_CODE] + "-" + [tbl_NIMSD_dbo_TIDWRREQ].[EQUIPMENT_NUMBER] AS EQ_TAG
,tbl_NIMSD_dbo_TIDWRREQ.WO_REQ_STATUS
,CDate(Format([WO_REQ_DATE_ENTER], "####\/##\/##")) AS WR_CREATION_DATE
FROM qryfrmOutput
INNER JOIN tbl_NIMSD_dbo_TIDWRREQ ON qryfrmOutput.SCI = tbl_NIMSD_dbo_TIDWRREQ.SYSTEM_CODE
WHERE (
((tbl_NIMSD_dbo_TIDWRREQ.SYSTEM_CODE) = Forms ! frmOutputDarlington ! ListSelectedSystem)
AND (
(CDate(Format([WO_REQ_DATE_ENTER], "####\/##\/##"))) >= Forms ! frmOutputDarlington ! TextStartDate
AND (CDate(Format([WO_REQ_DATE_ENTER], "####\/##\/##"))) <= (Forms ! frmOutputDarlington ! TextEndDate + 1)
)
);
The function that inserts the system code and date,
strSCI = ConcatRelated("[SCI]", "[tblSystemAssignmentList]", "[Facility] = '" & [TempVars]![varFacility] & "' AND [Selected] = True", , " OR ", "(tbl_NIMSD_dbo_TIDWRREQ.SYSTEM_CODE)='")
searchString = "(tbl_NIMSD_dbo_TIDWRREQ.SYSTEM_CODE)=Forms!frmOutputDarlington!ListSelectedSystem"
If InStr(1, SCIList, searchString) <> 0 Then
SCIList = Replace(SCIList, "(tbl_NIMSD_dbo_TIDWRREQ.SYSTEM_CODE)=Forms!frmOutputDarlington!ListSelectedSystem", strSCI)
Else
SCIList = Replace(SCIList, "(tbl_NIMSD_dbo_TIDWRREQ.SYSTEM_CODE)=[Forms]![frmOutputDarlington]![ListSelectedSystem]", strSCI)
End If
ConcatRelated
Dim rs As DAO.Recordset
Dim rsMV As DAO.Recordset
Dim strSQL As String
Dim strOut As String
Dim lngLen As Long
Dim bIsMultiValue As Boolean
ConcatRelated = Null
strSQL = "SELECT " & strField & " FROM " & strTable
If strWhere <> vbNullString Then
strSQL = strSQL & " WHERE " & strWhere
End If
If strOrderBy <> vbNullString Then
strSQL = strSQL & " ORDER BY " & strOrderBy
End If
Set rs = DBEngine(0)(0).OpenRecordset(strSQL, dbOpenDynaset)
bIsMultiValue = (rs(0).Type > 100)
Do While Not rs.EOF
If bIsMultiValue Then
Set rsMV = rs(0).Value
Do While Not rsMV.EOF
If Not IsNull(rsMV(0)) Then
strOut = strOut & rsMV(0) & strSeparator
End If
rsMV.MoveNext
Loop
Set rsMV = Nothing
ElseIf Not IsNull(rs(0)) And strFieldName = "(tblImportedSCRs.System) Like '*" Then
strOut = strOut & strFieldName & rs(0) & "*'" & strSeparator
ElseIf Not IsNull(rs(0)) Then
strOut = strOut & strFieldName & rs(0) & "'" & strSeparator
End If
rs.MoveNext
Loop
rs.Close
lngLen = Len(strOut) - Len(strSeparator)
If lngLen > 0 Then
ConcatRelated = Left(strOut, lngLen)
End If
exit_handler:
Set rsMV = Nothing
Set rs = Nothing
Exit Function
Err_Handler:
MsgBox "Error " & Err.Number & ": " & Err.Description, vbExclamation, "ConcatRelated()"
Resume exit_handler
End Function
When I run the code it should output the requested reports within the requested timeframe, however instead of the actual values it displays #name?
For a start, reduce the code and specify the parameters:
PARAMETERS
Forms!frmOutputDarlington!ListSelectedSystem Long,
Forms!frmOutputDarlington!TextStartDate DateTime,
Forms!frmOutputDarlington!TextEndDate DateTime;
SELECT
tbl_NIMSD_dbo_TIDWRREQ.WO_REQ_NUMBER,
tbl_NIMSD_dbo_TIDWRREQ.WR_TASK_TITLE,
"Click Here" AS [Work Request Description],
tbl_NIMSD_dbo_TIDWRREQ.SYSTEM_CODE,
tbl_NIMSD_dbo_TIDWRREQ.UNIT,
[tbl_NIMSD_dbo_TIDWRREQ].[Unit] & "-" & [tbl_NIMSD_dbo_TIDWRREQ].[SYSTEM_CODE] & "-" & [tbl_NIMSD_dbo_TIDWRREQ].[EQUIPMENT_NUMBER] AS EQ_TAG,
tbl_NIMSD_dbo_TIDWRREQ.WO_REQ_STATUS,
DateValue([WO_REQ_DATE_ENTER]) AS WR_CREATION_DATE
FROM
qryfrmOutput
INNER JOIN
tbl_NIMSD_dbo_TIDWRREQ ON
qryfrmOutput.SCI = tbl_NIMSD_dbo_TIDWRREQ.SYSTEM_CODE
WHERE
tbl_NIMSD_dbo_TIDWRREQ.SYSTEM_CODE = Forms!frmOutputDarlington!ListSelectedSystem
AND
DateValue([WO_REQ_DATE_ENTER]) >= Forms!frmOutputDarlington!TextStartDate
AND
DateValue([WO_REQ_DATE_ENTER]) <= DateAdd("d", 1, Forms!frmOutputDarlington!TextEndDate)
Thank you to all your responses.
I have a table with one id field and R1-R30 fields.
I was able to concatenate R1-R30 fields in a query using
Route: Trim([R1] & IIf([R2]="",""," ") & [R2] & IIf([R3]="",""," ") & [R3] & IIf([R4]="",""," ") & [R4] & IIf([R5]="",""," ") & [R5] & IIf([R6]="",""," ") & [R6] & IIf([R7]="",""," ") & [R7] & IIf([R8]="",""," ") & [R8] & IIf([R9]="",""," ") & [R9] & IIf([R10]="",""," ") & [R10] & IIf([R11]="",""," ") & [R11] & IIf([R12]="",""," ") & [R12] & IIf([R13]="",""," ") & [R13] & IIf([R14]="",""," ") & [R14] & IIf([R15]="",""," ") & [R15] & IIf([R16]="",""," ") & [R16] & IIf([R17]="",""," ") & [R17] & IIf([R18]="",""," ") & [R18] & IIf([R19]="",""," ") & [R19] & IIf([R20]="",""," ") & [R20] & IIf([R21]="",""," ") & [R21] & IIf([R22]="",""," ") & [R22] & IIf([R23]="",""," ") & [R23] & IIf([R24]="",""," ") & [R24] & IIf([R25]="",""," ") & [R25] & IIf([R26]="",""," ") & [R26] & IIf([R27]="",""," ") & [R27] & IIf([R28]="",""," ") & [R28] & IIf([R29]="",""," ") & [R29] & IIf([R30]="",""," ") & [R30])
My question is if the Join function I found can be applied to a query where the delimeter could be a spare, comma or slash.
Join (source_array,[delimiter])
Thanks
This would be the code to take all values of 1 single recordset into a bidimensional array, and then take those values into a unidimensional array (excluding null values, because null values cannot be joined with JOIN).
I think it would be better just looping trough every field with the loop, but in case it might help, i'll post it.
To replicate your issue, I just created a database with 1 single table with 2 records:
I'll concatenate all fields, excluding ID field. So with an easy query, I can get a recordset of 1 single record, using ID field as parameter:
SELECT Tabla1.Field1, Tabla1.Field2, Tabla1.Field3, Tabla1.Field4
FROM Tabla1
WHERE (((Tabla1.Id)=1));
And then the VBA code to Msgbox the fields joined, using a comma as delimiter.
Sub JOIN_RST()
Dim rst As Recordset
Dim vArray As Variant
Dim SingleArray() As Variant
Dim i As Long
Dim MySQL As String
Dim STRJoined As String
MySQL = "SELECT Tabla1.Field1, Tabla1.Field2, Tabla1.Field3, Tabla1.Field4 " & _
"FROM Tabla1 WHERE (((Tabla1.Id)=2));" 'query to get a single recordset.
Set rst = Application.CurrentDb.OpenRecordset(MySQL, 2, 4)
DoEvents
If rst.RecordCount > 0 Then
rst.MoveLast
rst.MoveFirst
vArray = rst.GetRows
ReDim SingleArray(UBound(vArray))
For i = 0 To UBound(SingleArray)
If IsNull(vArray(i, 0)) = True Then
SingleArray(i) = ""
Else
SingleArray(i) = vArray(i, 0)
End If
Next i
Debug.Print vArray(0, 0) 'Field 1
Debug.Print vArray(1, 0) 'Field 2
Debug.Print vArray(2, 0) 'Field 3
Debug.Print vArray(3, 0) 'Field 4
STRJoined = Join(SingleArray, ",")
Debug.Print STRJoined
End If
Set rst = Nothing
Erase vArray
Erase SingleArray
DoEvents
End Sub
If I execute this code using as WHERE parameter ID=1 , in debugger Window I get:
First Record
1
Null
My first record. Got a null value in Field 3 (it's empty)
First Record,1,,My first record. Got a null value in Field 3 (it's empty)
With ID=2 I get:
Second Record
2
Not null
Second Record
Second Record,2,Not null,Second Record
So this kinda works. I hope you can adapt it to your needs. but as i said. looking at the code, I think it would be easier just looping trough fields in a single query with all records. something like this:
Sub LOOPING_TROUGHT_FIELDS()
Dim RST As Recordset
Dim Joined_Records() As Variant
Dim i As Long
Dim MySQL As String
Dim STRJoined As String
Dim FLD As Field
MySQL = "SELECT Tabla1.Field1, Tabla1.Field2, Tabla1.Field3, Tabla1.Field4 " & _
"FROM Tabla1;" 'query to get all recordset you want to join
Set RST = Application.CurrentDb.OpenRecordset(MySQL, 2, 4)
DoEvents
If RST.RecordCount > 0 Then
RST.MoveLast
RST.MoveFirst
i = 0
ReDim Joined_Records(RST.RecordCount)
Do Until RST.EOF = True
For Each FLD In RST.Fields
If IsNull(FLD.Value) = True Then
STRJoined = STRJoined & "" & ","
Else
STRJoined = STRJoined & FLD.Value & ","
End If
Next FLD
Joined_Records(i) = Left(STRJoined, Len(STRJoined) - 1) 'we get 1 minus because there is an extra comma at end
i = i + 1
STRJoined = ""
RST.MoveNext
Loop
End If
Set RST = Nothing
Set FLD = Nothing
For i = 0 To UBound(Joined_Records) Step 1
Debug.Print Joined_Records(i)
Next i
Erase Joined_Records
End Sub
I don't know how many records you got. Try both and check how long does each option takes, and then choose 1.
Hope you can adapt all this to your needs. Welcome to SO.
I am trying to figure out what wrong may be with a function in Excel that tries to join two tables. I presume the error is somewhere in SQL string.
The function works well without a join, returning correctly a table to an array - range of cells. ie when strSQL is only "SELECT * FROM [" & currAddress & "] "
It does not work when the string contains a join, ie strSQL = "SELECT * FROM [" & currAddress & "] " & _
"LEFT JOIN [" & currAddress2 & "] ON [Indeks].[" & currAddress & "] = [Indeks2].[" & currAddress2 & "];"
Here is my code, thank you for help:
Function SQL(dataRange As Range, dataRange2 As Range) As Variant
Application.Volatile
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim currAddress, currAddress2 As String
Dim varHdr, varDat, contentOut As Variant
Dim nc, nr, i, j As Long
SQL = Null
currAddress = ActiveSheet.Name & "$" & dataRange.Address(False, False)
Debug.Print currAddress
currAddress2 = ActiveSheet.Name & "$" & dataRange2.Address(False, False)
Debug.Print currAddress2
strFile = ThisWorkbook.FullName
strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFile _
& ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=0"";"
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
rs.CursorLocation = adUseClient ' required to return the number of rows correctly
cn.Open strCon
strSQL = "SELECT * FROM [" & currAddress & "] " & _
"LEFT JOIN [" & currAddress2 & "] ON [Indeks].[" & currAddress & "] = [Indeks2].[" & currAddress2 & "];"
Debug.Print strSQL
rs.Open strSQL, cn
'Check if recordset is empty
If rs.EOF Then
MsgBox "Function does not return any values"
SQL = ""
Exit Function
End If
' Process Column Headings
nc = rs.Fields.Count
ReDim varHdr(nc - 1, 0)
For i = 0 To rs.Fields.Count - 1
varHdr(i, 0) = rs.Fields(i).Name
Next
' Get Rows from the Recordset
nr = rs.RecordCount
varDat = rs.GetRows
' Combing Header and Data and Transpose
ReDim contentOut(0 To nr, 0 To nc - 1)
For i = 0 To nc - 1
contentOut(0, i) = varHdr(i, 0)
Next
For i = 1 To nr
For j = 0 To nc - 1
contentOut(i, j) = varDat(j, i - 1)
Next
Next
' Optional solution: Write Output Array to Sheet2
' With Sheet2
' .Cells.Clear
' .Range("A1").Resize(nr, nc) = contentOut
' End With
'Figure out size of calling range which will receive the output array
Dim nRow As Long: nRow = Application.Caller.Rows.Count
Dim nCol As Long: nCol = Application.Caller.Columns.Count
'Error if calling range too small
If nRow < UBound(contentOut, 1) Or nCol < UBound(contentOut, 2) Then
'Popup message
'MsgBox "your range is too small."
' or return #VALUE! error
SQL = "Too small range" 'CVErr(xlValue)
' or both or whatever else you want there to happen
Exit Function
End If
'Initialise output array to match size of calling range
Dim varOut As Variant
ReDim varOut(1 To nRow, 1 To nCol)
'And fill it with some background value
Dim iRow As Long
Dim iCol As Long
For iRow = 1 To nRow
For iCol = 1 To nCol
varOut(iRow, iCol) = "" ' or "funny bear", or whatever
Next
Next
'Put content in output array and return
For iRow = 0 To UBound(contentOut, 1)
For iCol = 0 To UBound(contentOut, 2)
varOut(iRow + 1, iCol + 1) = contentOut(iRow, iCol)
Next
Next
SQL = varOut
'Cleanup
Erase contentOut
Erase varHdr
Erase varDat
rs.Close
Set rs = Nothing
Set cn = Nothing
End Function
It looks like you are not specifying the fields/columns in the join. Both currAddress and curAddress2 look like tables. The SQL should be something like:
strSQL = "SELECT * FROM [Table1] " & _
"LEFT JOIN [Table2] ON [Table1].[Field] = [Table2].[Field];"
Are Indeks and Indeks2 your field names? If so, you need to place the field name after the table name:
strSQL = "SELECT * FROM [" & currAddress & "] " & _
"LEFT JOIN [" & currAddress2 & "] ON [" & currAddress & "].[Indeks] = [" & currAddress2 & "].[Indeks2];"
I believe 'Indeks' is your common field in the two tables, then strSQL should be this:
strSQL = "SELECT * FROM [" & currAddress & "] " & _
"LEFT JOIN [" & currAddress2 & "] ON [" & currAddress & "].[Indeks] = [" & currAddress2 & "].[Indeks]"
rs2.FindFirst "[aniin] ='" & strTemp & "'"
aniin being an alias from the SQL within the function.
also tried ...
rs2.FindFirst (niin = newdata)
is my attempt to isolate the field name niin from the record value in the form from the one in the strSQL2. All my attempts have failed. I am trying to make sure that what the user typed in does match the list from the SQL string.
Private Function IsPartOfAEL(newdata) As Boolean
On Error GoTo ErrTrap
Dim db2 As DAO.Database
Dim rs2 As DAO.Recordset
Dim strTemp As String
strSQL2 = "SELECT tbl_ael_parts.master_ael_id, tbl_master_niin.niin as aniin " & vbCrLf & _
"FROM tbl_master_niin INNER JOIN tbl_ael_parts ON tbl_master_niin.master_niin_id = tbl_ael_parts.master_niin_id " & vbCrLf & _
"WHERE (((tbl_ael_parts.master_ael_id)= " & Forms!frm_qry_niin_local!master_ael_id & "));"
Set db2 = CurrentDb
Set rs2 = db2.OpenRecordset(strSQL2)
strTemp = newdata
If rs2.RecordCount <> 0 Then
rs2.FindFirst "[aniin] ='" & strTemp & "'"
If rs2.NoMatch Then
IsPartOfAEL = False
Else
IsPartOfAEL = True
End If
Else
MsgBox "Query Returned Zero Records", vbCritical
Exit Function
End If
rs.Close
Set rs2 = Nothing
Set db2 = Nothing
ExitHere:
Exit Function
ErrTrap:
MsgBox Err.description
Resume ExitHere
End Function
First: You should never include a constant like vbCrLf when building a query string. The query parser doesn't care if there's a linefeed, and in fact this can sometimes cause issues.
Your code seems to do nothing more that verify whether the value in newdata exists in the tbl_ael_parts and is associated with the value master_ael_id value currently showing on frm_qry_niin_local. If so, then just use DCount, or use this for your query:
strSQL2 = "SELECT tbl_ael_parts.master_ael_id INNER JOIN tbl_ael_parts ON
tbl_master_niin.master_niin_id = tbl_ael_parts.master_niin_id WHERE (((tbl_ael_parts.master_ael_id)=
" & Forms!frm_qry_niin_local!master_ael_id & ") AND niin=" & newdata & ");"
Dim rst As DAO.Recordset
Set rst = currentdb.OPenrecordset(strsql2)
If (rst.EOF and rst.BOF) Then
' no records returned
Else
' records found
End If
If niin is a Text field:
strSQL2 = "SELECT tbl_ael_parts.master_ael_id INNER JOIN tbl_ael_parts ON
tbl_master_niin.master_niin_id = tbl_ael_parts.master_niin_id WHERE (((tbl_ael_parts.master_ael_id)=
" & Forms!frm_qry_niin_local!master_ael_id & ") AND (niin='" & newdata & "'));"
If both niin and master_ael_id are Text fields:
strSQL2 = "SELECT tbl_ael_parts.master_ael_id INNER JOIN tbl_ael_parts ON
tbl_master_niin.master_niin_id = tbl_ael_parts.master_niin_id WHERE (((tbl_ael_parts.master_ael_id)=
'" & Forms!frm_qry_niin_local!master_ael_id & "') AND (niin='" & newdata & "'));"
I created an Access database which I want to distribute to a small group. While I can always export the tables in excel and merge them/append data there, is there a way to sync the databases, maybe by using VBA?
To expound further, in one form in the database application, a sync button may exist, and onclick, a dialog box may open to look for the accdb to sync with. What ensues is that the VBA will "sync" the table (which of course is of the same structure) in question between the two accdbs.
Is this possible? Insights will be good. Thank you!
Yes, it is perfectly possible. Here are some notes on comparing two DBs and logging changes.
The procedure requires the following at the top of the module:
Dim strFileNew As String
Dim strFileOld As String
Dim strLog As String
Dim dbOld As Database
The variables might contain:
strLog = "log.txt"
strFileNew = "z:\docs\dbNew.mdb"
strFileOld = "z:\docs\dbOld.mdb"
Set dbOld = OpenDatabase(strFileOld)
Then the comparison:
Sub LogCompareDB(db As Database)
''References : Windows Script Host Object Model
'' This is set by default for a number of versions
'' : Microsoft DAO x.x Object Library
'' For 2010, the DAO library is called
'' :Microsoft Office 12.0 Access Database Engine Object Library
Dim tdf As TableDef
Dim rs0 As DAO.Recordset
Dim rs1 As DAO.Recordset
Dim fld As DAO.Field
Dim idx As Index
Dim idxPrimary As Index
Dim strIndexList As String
Dim strIndex As String
Dim strID As String
Dim strSQL As String
Dim strChanged As String
Dim blnNew As Boolean
Dim fs As New FileSystemObject
Dim ts As TextStream
Set ts = fs.CreateTextFile(strLog, True)
''For each table in the old database
''(It would probably be a good idea to check the
''new database for added tables)
For Each tdf In db.TableDefs
'' Skip system tables
If Left(tdf.Name, 4) <> "MSys" Then
strIndex = vbNullString
Set idxPrimary = Nothing
strIndexList = vbNullString
''Get the primary index and index fields
For Each idx In tdf.Indexes
If idx.Primary = True Then
Set idxPrimary = idx
For Each fld In idx.Fields
strIndex = strIndex & " AND t0.[" & fld.Name _
& "] = t1.[" & fld.Name & "]"
strIndexList = strIndexList & "," & fld.Name
Next
strIndex = Mid(strIndex, 5)
End If
Next
''There is no basis for comparison if there is no index.
''A unique index would also be a possibility, but hey, let's
''not go over the top :)
If strIndex > vbNullString Then
''Select all records from the table for both databases
strSQL = "SELECT * FROM [;DATABASE=" & strFileNew & "].[" _
& tdf.Name & "] As t0 LEFT JOIN [" _
& tdf.Name & "] As t1 ON " & strIndex
Set rs0 = db.OpenRecordset(strSQL)
''A convenient list of fields from the old database
''It would probably be a good idea to check the
''new database for added fields.
strSQL = "SELECT * FROM [;DATABASE=" & strFileOld & "].[" _
& tdf.Name & "] As t0 WHERE 1=2"
Set rs1 = db.OpenRecordset(strSQL)
Do While Not rs0.EOF
strID = vbNullString
blnNew = False
''If the index fields are null, then it is a new record
For Each fld In idxPrimary.Fields
strID = strID & fld.Name & ": " & rs0("[t0." & fld.Name & "]") & vbCrLf
If IsNull(rs0("[t1." & fld.Name & "]")) Then
blnNew = True
End If
Next
If blnNew Then
''Write to log
ts.WriteLine "NEW RECORD " & strID & vbCrLf
Else
''Not a new record, so is it a changed record?
strChanged = vbNullString
For Each fld In rs1.Fields
''No need to check index fields, because they are equal
If InStr(strIndexList, fld.Name) = 0 Then
''Add null string for purposes of comparison ''trailing
If "" & rs0("[t0." & fld.Name & "]") <> "" & rs0("[t1." & fld.Name & "]") Then
strChanged = strChanged & vbCrLf _
& fld.Name & " Is: " & Trim(rs0("[t0." & fld.Name & "]")) _
& " Was: " & Trim(rs0("[t1." & fld.Name & "]"))
End If
End If
Next
If strChanged <> vbNullString Then
''Write to log
ts.WriteLine "CHANGED RECORD " & strID
ts.WriteLine strChanged & vbCrLf
End If
End If
rs0.MoveNext
Loop
Else
ts.WriteLine "NO PRIMARY INDEX " & tdf.Name & vbCrLf
End If
End If
Next
ts.Close
FollowHyperlink strLog
End Sub
Option Compare Database
Private Sub Command4_Click()
Dim tablename1, tablename2 As String
tablename1 = Text0.Value
tablename2 = Text2.Value
'On Error GoTo Err_cmdValidateGeneralInfo_Click
Dim F As DAO.Field
Dim rs As DAO.Recordset
Dim rs1 As DAO.Recordset
Set curDB = CurrentDb()
'If Me.DateModified = Date Then
'Adds new employees to the TT_GeneralInfo table in the FTEI_PhoneBook.mdb - which is used thru out the AP databases.
' DoCmd.OpenQuery "qryEmpData_TT_General"
strsql = "Select * from " & tablename1
Set rs = curDB.OpenRecordset(strsql)
strsql1 = "Select * from " & tablename2
DoCmd.CopyObject , "Unmatched_records", acTable, tablename1
curDB.Execute "DELETE FROM Unmatched_records"
Set rs1 = curDB.OpenRecordset(strsql1)
Do Until rs.EOF
For Each F In rs.Fields
If rs.Fields(F.Name) <> rs1.Fields(F.Name) Then
'rs.Edit
strsql = "Select * into test from " & tablename1 & " where " & F.Name & " = """ & rs.Fields(F.Name) & """"
DoCmd.RunSQL strsql
If DCount(F.Name, "test") <> 0 Then
GoTo append_unmatch
'appending unmacthed records
append_unmatch:
strsql2 = "insert into Unmatched_records Select * from test"
DoCmd.RunSQL strsql2
'if record doesnt match move to next one
GoTo Nextrecord
End If
' rs.Fields(F.Name) = rs1.Fields(F.Name)
' rs.Update
End If
Next F
Nextrecord:
rs.MoveNext
rs1.MoveNext
Loop
If DCount("test", F.Name) <> 0 Then
MsgBox ("The two tables didnt match. Check table test for unmatching reocrds.")
Else
MsgBox ("Tables match!")
End If
End Sub