I've previously posted a version of this code here:
MS Access VBA code to compare records in a table and combine data where necessary
To repeat what I'm looking for from my previous post:
Note I have written "Suspect there is a better way to do this" etc. in the comments of a line which I think is questionable, so if you do a Ctrl+F for "suspect" then you'll find things I am particularly unsure of.
Also I should explain that for the purposes of this code review, I am not really using Access as a relational database, I am merely taking the output of some CAD (design) software, processing it in a certain way, then outputting it to print.
What I'd like to get from this review is:
Tighten this all up functionally, perhaps speed the code up where possible. I suspect that maybe some of my loops, ways of moving through recordsets etc. may be inefficient.
I think perhaps I could be making better use of SQL queries - currently the code doesn't use them but I suspect that using saved queries etc. in some places (executed through VBA) might be quicker than using recordsets in VBA - eg. the parts where records are compared to one another.
Find out where I have done things which are considered bad practice.
I'm less concerned about things like Hungarian notation and making the code pretty.
Here's the revised code:
Option Compare Database
Option Explicit
Public Const gcfHandleErrors As Boolean = False ' Globally enable/disable error handling.
Public Const strSeparator As String = "~"
Public Const strBlankKey As String = "¿"
Dim db As dao.Database
Dim RS_BOM_Imported As dao.Recordset, RS_Dflt_Params_List As dao.Recordset, RS_SPECIAL_ITEMS As dao.Recordset
Dim RS_CurrDocTbl As dao.Recordset
Dim RS_tmpTblDocsOutList As dao.Recordset
Dim strREF As String
Dim strCOMMENT As String
Public Declare Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long)
Dim strDocOut As String
Sub condenseOutputDocs()
If gcfHandleErrors Then On Error GoTo Err_General
'------------------------------------------------------------------------------------
' Condenses output documents by combining records where all fields except NB, REF and COMMENT match
'
' Adds NBs from combined fields together to give total number of components
'
' Also takes all REF, NB and COMMENTS and concatenates them into a string separated by the "~" character
' for later processing / recombining - temporarily stored in the COMMENT field.
'
' Also replaces blank fields temporarily with the "¿" character as a special flag for later processing
'
' So for example the following 2 records (note that fields REF, NB, COMP_NAME and COMMENT are present in all tables, but
' there may be any number of fields inbetween COMP_NAME and COMMENT with different names, but COMP_NAME and all of these
' fields must match for a record to be combined):
'
' REF NB COMP_NAME PARAMS COMMENT
' A 2 RAFTER L=2000 P=25 BLAH
' B 5 RAFTER L=2000 P=25 FEH
' C 3 RAFTER L=2000 P=25 BLAH
' D 2 RAFTER L=2000 P=25 [BLANK]
' [BLANK] 4 RAFTER L=2000 P=25 [BLANK]
' [BLANK] 6 RAFTER L=2000 P=25 FOO
'
' then become as an intermediate step:
'
' REF NB COMP_NAME PARAMS COMMENT
' A 22 RAFTER L=2000 P=25 A~2~BLAH~B~5~FEH~C~3~BLAH~D~2~¿~¿~4~¿~¿~6~FOO~
' Lines show separation of records: | | | | | | |
' (note REF is currently unchanged and will be the REF from the first found record which is matched to others)
' (Also blank values are replaced with ¿ for later processing)
'
' And eventually in a later module will be processed further and become:
'
' REF NB COMP_NAME PARAMS COMMENT
' A:2,B:5,C:3,D:2 16 RAFTER L=2000 P=25 [A:2/C:3 - BLAH] [B:5 - FEH] [NoRef:6 - FOO]
'
'-------------------------------------------------------------------------------------
Dim strREF1 As String
Dim intNB1 As Integer
Dim strREF2 As String
Dim strREFnew As String
Dim intNB2 As Integer
Dim strCOMMENT1 As String
Dim strCOMMENT2 As String
Dim strCOMMENTnew As String
Dim td As TableDef
Dim fldDef As Field
Dim strFldNameList As String
Dim strFldNameArray() As String
Dim intFldCount As Integer
Dim intFldIndex As Integer
Dim strThisFldName As String
Dim str1stRecContents As String
Dim str2ndRecContents As String
Dim lngID1 As Long
Dim lngID2 As Long
Dim lngCurrDocTblRecordCount As Long
Set db = CurrentDb
Set RS_tmpTblDocsOutList = db.OpenRecordset("tmpTblDocsOutList", dbOpenDynaset) 'tmpTblDocsOutList contains a list of all tables to be processed in this way
'tmbTblDocstOutlist is constructed earlier in another sub.
Do Until RS_tmpTblDocsOutList.EOF ' loop through output docs
strDocOut = RS_tmpTblDocsOutList![OUT_DOCUMENT] & vbNullString
Debug.Print "-------------------------------------------------------------------"
Debug.Print "strDocOut = " & strDocOut
' Open a recordset for the document table
Set RS_CurrDocTbl = db.OpenRecordset(strDocOut, dbOpenDynaset)
Set td = db.TableDefs(strDocOut)
RS_CurrDocTbl.MoveLast
lngCurrDocTblRecordCount = RS_CurrDocTbl.RecordCount ' count the records - suspect there may be a better way, but I need to populate the recordset anyway.
RS_CurrDocTbl.MoveFirst
Debug.Print "curr doc tbl record count = " & lngCurrDocTblRecordCount
lngID1 = 0 '1st record ID
Do While lngID1 < (lngCurrDocTblRecordCount) ' loop through records (first)
RS_CurrDocTbl.MoveFirst
RS_CurrDocTbl.Move (lngID1) 'move to 1st rec currently being worked on - Suspect there is a better way of doing this.
' initialise / clear variables
strFldNameList = vbNullString
str1stRecContents = vbNullString
str2ndRecContents = vbNullString
intFldCount = td.Fields.Count ' get total number of fields
' Feed the names of the arbitrary fields in this document that contain parameters, into a comma-delimited string
For Each fldDef In td.Fields
strFldNameList = strFldNameList & fldDef.Name & "," ' append this field name to the string, then the delimiting comma - suspect that this is unnecessary?
Next
strFldNameList = Left(strFldNameList, Len(strFldNameList) - 1) 'delete final comma from delimited string
ReDim strFldNameArray(0 To intFldCount - 1)
' Create an array from the string and store it into strFldNameArray
strFldNameArray = Split(strFldNameList, ",")
' For the first comparison record, get the contents of the COMP_NAME field and the arbitrary fields containing
' parameters and feed them into a concatenated string sequence:
For intFldIndex = 2 To intFldCount - 2 ' for each of the fields except the 1st (REF), 2nd (NB) and final (COMMENT) fields (note this structure will always be the same)
strThisFldName = strFldNameArray(intFldIndex) ' get this field name
str1stRecContents = str1stRecContents & RS_CurrDocTbl(strThisFldName) & vbNullString ' append the field's contents to the string
Next
strREF1 = RS_CurrDocTbl![REF] & vbNullString
strREF1 = markStringAsBlank(strREF1) ' replaces strREF1 with strBlankKey if it is an empty string, otherwise leaves it alone
intNB1 = RS_CurrDocTbl![NB] ' each record will ALWAYS have a NB - will be an int, usually no more than ~60
strCOMMENT1 = RS_CurrDocTbl![COMMENT] & vbNullString
strCOMMENT1 = markStringAsBlank(strCOMMENT1) ' replaces strCOMMENT1 with strBlankKey if it is an empty string, otherwise leaves it alone
strCOMMENT1 = constructFirstCommentIfNeeded(strREF1, intNB1, strCOMMENT1) 'if comment does not already contain some concatenated comment from previous run, then create new _
concatenated string from REF, NB and COMMENT
Debug.Print "strCOMMENT1 = " & strCOMMENT1
RS_CurrDocTbl.Edit
RS_CurrDocTbl![COMMENT] = strCOMMENT1 ' save new comment string into table
RS_CurrDocTbl.Update
lngID2 = lngID1 + 1 ' lngID1 is current record, set lngID2 (record to be compared to current record) to initially be the next record in the list
Do 'loop through records (2nd)
RS_CurrDocTbl.MoveFirst ' move to first record in table
RS_CurrDocTbl.Move (lngID2) ' then move [lngID2] spaces forward to seek to correct record for comparisons - suspect there is a better way
str2ndRecContents = vbNullString ' initialise variable / clear from previous run
If Not RS_CurrDocTbl.EOF Then
For intFldIndex = 2 To intFldCount - 2 ' for each of the fields except the 1st (REF), 2nd (NB) and final (COMMENT) fields
strThisFldName = strFldNameArray(intFldIndex) ' get this field name
str2ndRecContents = str2ndRecContents & RS_CurrDocTbl(strThisFldName) & vbNullString ' append its contents to the string
Next
strREF2 = RS_CurrDocTbl![REF] & vbNullString
strREF2 = markStringAsBlank(strREF2) ' replaces strREF2 with strBlankKey if it is an empty string, otherwise leaves it alone
intNB2 = RS_CurrDocTbl![NB]
strCOMMENT2 = RS_CurrDocTbl![COMMENT] & vbNullString
strCOMMENT2 = markStringAsBlank(strCOMMENT2) ' replaces strCOMMENT2 with strBlankKey if it is an empty string, otherwise leaves it alone
strCOMMENT2 = constructFirstCommentIfNeeded(strREF2, intNB2, strCOMMENT2) 'if comment does not already contain some concatenated _
comment from previous run, then create new concatenated string from REF, NB and COMMENT
RS_CurrDocTbl.Edit
RS_CurrDocTbl![COMMENT] = strCOMMENT2
RS_CurrDocTbl.Update
Debug.Print "strComment2 = " & strCOMMENT2
If str1stRecContents = str2ndRecContents Then ' if a match is found
RS_CurrDocTbl.Delete ' delete current (2nd) record
lngCurrDocTblRecordCount = lngCurrDocTblRecordCount - 1 ' decrement number of records
RS_CurrDocTbl.MoveFirst
RS_CurrDocTbl.Move (lngID1) ' move to 1st record
RS_CurrDocTbl.Edit
RS_CurrDocTbl![NB] = RS_CurrDocTbl![NB] + intNB2 ' add numbers to get total count
RS_CurrDocTbl![COMMENT] = RS_CurrDocTbl![COMMENT] & strCOMMENT2
RS_CurrDocTbl.Update
' this leaves ref unchanged as this will be processed in a later module by extracting info from the (now combined and concatenated) comment field
Debug.Print "Match found - Records combined"
Debug.Print "lngCurrDocTblRecordCount = " & lngCurrDocTblRecordCount
Else
Debug.Print "No match found"
lngID2 = lngID2 + 1 ' only increase ID of 2nd record being compared if it has not just been deleted
End If ' end record contents comparison
End If ' end EOF testing
Loop Until RS_CurrDocTbl.EOF ' end looping through (2nd) records
lngID1 = lngID1 + 1 ' increment 1st record ID
Debug.Print "******* lngID1 = " & lngID1
Loop ' end looping through (1st) records
RS_tmpTblDocsOutList.MoveNext ' move to next table
Loop ' end looping through documents/tables
RS_CurrDocTbl.Close ' close current table
RS_tmpTblDocsOutList.Close ' close list of tables
condenseComments ' call sub which condenses comments
Exit Sub
' General Error Handler:
Exit_Err_General:
Exit Sub
Err_General:
MsgBox "Oops! There's been an error! Error " & Err.Number & ": " & Err.Description
close_all_open_tables ' what it says
Resume Exit_Err_General
End Sub
Private Function markStringAsBlank(str As String) As String
If LenB(str) = 0 Then ' if string is blank ( = "")
markStringAsBlank = strBlankKey ' assign blank key value (Constant defined in module header)
Else
markStringAsBlank = str ' otherwise return the original string.
End If
End Function
Private Function constructFirstCommentIfNeeded(strREF As String, intNB As Integer, strCOMMENT As String) As String
If Not Right(strCOMMENT, 1) = strSeparator Then
constructFirstCommentIfNeeded = strREF & strSeparator & intNB & strSeparator & strCOMMENT & strSeparator
Else
constructFirstCommentIfNeeded = strCOMMENT
End If
End Function
Since last time I have:
- Changed the way my loops work - using
Do Until
rather thanDo While Not
. - Implemented the constants
strSeparator
andstrBlankKey
for my concatenated string separation character and my key value to indicate a blank field. - Replaced instances of
""
withvbNullString
. - Written Functions for
markStringAsBlank
andconstructFirstCommentIfNeeded
in an effort to follow DRY. - Removed unused variables from my sub
Note: I have also now included the module header which may contain definitions for objects not used in this sub, which are used elsewhere in the module.