Code
Please be warned that this is likely ugly and inefficient, but I have been trying to use some work arounds to make it work.
Sub UpdateGaps()
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim updatetable As DAO.Recordset
Dim ident As String
Dim length As Integer
Dim xp(8) As Variant, coa(8) As Variant
Dim e(8) As Integer
Dim field(8) As String
Dim xpvalue As Integer, coavalue As Integer
Dim xpcoatype As String, edesc As String
Dim x As Integer
Dim xstr As String
Dim strfield As String
Dim fieldname As Object
'define field names
field(0) = "Price"
field(1) = "Amount(G)"
field(2) = "Mty Dt"
field(3) = "Commission"
field(4) = "Principal"
field(5) = "Broker ID"
field(6) = "Short Note4"
'define array lengths for looping
length = 6
Set dbs = CurrentDb()
Set rst = dbs.OpenRecordset("XPCOA", dbOpenDynaset)
Set updatetable = dbs.OpenRecordset("CancelCorrectErrorField", dbOpenDynaset)
rst.MoveFirst
' loop through records
Do Until rst.EOF
'reset variables
x = 0
xpvalue = 0
coavalue = 0
edesc = ""
'reset comparative variables
For x = 0 To length
xp(x) = 0
coa(x) = 0
e(x) = 0
Next x
With rst
'get the identifier to compare
ident = !Identifier
'pass values to function to record different lines for two specific record types
xpcoacheck xp(), coa(), rst, ident, edesc, xpvalue, coavalue
End With
x = 0
'check that both of the comperative entries are present
If xpvalue = 0 Or coavalue = 0 Then
'update table
With updatetable
.AddNew
!Identifier = ident
!ErrorResponse = edesc
.Update
End With
Else
'compare and enter errors into array
For x = 0 To length
If xp(x) <> coa(x) Then
e(x) = 1
End If
Next x
'update listing of error codes
With updatetable
.MoveLast
If ident = !Identifier Then
.Edit
!ErrorResponse = edesc
.Update
x = 0
For x = 0 To length
If e(x) > 0 Then
xstr = CStr(x)
'here's where it all starts to go wrong,
'I can't seem to update data to go into each column
'by position in the array. Every syntax either comes
' back as error 3265 or in it's current iteration
' error 91. I use the same code again, so If I can
' solve it once, applying it again shouldn't be a problem
fieldname = "ErrorField" & xstr
.Edit
!["fieldname"] = True
.Update
End If
Next x
Else
.AddNew
!Identifier = ident
!ErrorResponse = edesc
.Update
x = 0
For x = 0 To length
If e(x) > 0 Then
xstr = CStr(x)
fieldname = "ErrorField" & xstr
.Edit
![fieldname] = True
.Update
End If
Next x
End If
End With
End If
rst.MoveNext
Loop
End Sub
Public Function xpcoacheck(ByRef xp(), ByRef coa(), ByRef rst, ByRef ident, ByRef edesc, ByRef xpvalue, ByRef coavalue)
' this is a work around because i couldn't pull the
'field names directly from the field array
Dim xpcoatype As String
Dim length As Integer
length = 8
With rst
Do Until rst.EOF
Nextitemcheck:
xpcoatype = !Type
Select Case xpcoatype
Case "XP"
If xpvalue = 0 Then
xpvalue = rst.RecordCount
x = 0
For x = 0 To length
Select Case x
Case 0
xp(x) = ![Price]
Case 1
xp(x) = ![Amount(G)]
Case 2
xp(x) = ![Mty Dt]
Case 3
xp(x) = ![Commission]
Case 4
xp(x) = ![Principal]
Case 5
xp(x) = ![Broker ID]
Case 6
xp(x) = ![Short Note4]
Case Else
End Select
Next x
Else
edesc = edesc & "Multiple XP values " & rst.RecordCount
End If
Case "COA"
If coavalue = 0 Then
coavalue = rst.RecordCount
x = 0
For x = 0 To length
Select Case x
Case 0
coa(x) = ![Price]
Case 1
coa(x) = ![Amount(G)]
Case 2
coa(x) = ![Mty Dt]
Case 3
coa(x) = ![Commission]
Case 4
coa(x) = ![Principal]
Case 5
coa(x) = ![Broker ID]
Case 6
coa(x) = ![Short Note4]
Case Else
End Select
Next x
Else
edesc = edesc & "Multiple COA values " & rst.RecordCount
End If
Case Else
edesc = edesc & "Not an XP or COA Code " & rst.RecordCount
End Select
rst.FindNext ![Identifier] = ident
If .NoMatch Then
If coavalue = 0 Or xpvalue = 0 Then
edesc = edesc & "No Matches Found"
Exit Function
Else
Exit Function
End If
Else
GoTo Nextitemcheck
End If
rst.MoveNext
Loop
End With
End Function
thanks for your help, I know this is a lot of code.... I have hilighted the problem area in red. Thanks
