MS Access VBA code to compare records in a table and combine data - revised

Question

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 than Do While Not.
• Implemented the constants strSeparator and strBlankKey for my concatenated string separation character and my key value to indicate a blank field.
• Replaced instances of "" with vbNullString.
• Written Functions for markStringAsBlank and constructFirstCommentIfNeeded 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.

Answer 1

This is a huge improvement over the last version. I'll try to give you some pointers on how to improve this farther, but I am also going to tell you this. Your database is very poorly designed (if not downright broken) and nothing we do here will fix that. If you were using proper keys on your database, you might be able to develop a sql solution to this. You use REF as a key, but don't have it defined as such. That column should not allow nulls. Period. I suspect that is the source of your woes and the rest of this is a symptom of that. Now that that's out of the way, let's see what we can do short term to clean this up further...

Why are you adding an empty string to the end of strDocOut? That doesn't do anything at all. (Note: I just found several more instances of this. I really don't understand it.)

strDocOut = RS_tmpTblDocsOutList![OUT_DOCUMENT] & vbNullString

Here you're moving to the first record, and then immediately moving to the lngID1th record each time though your loop. You should probably just find the matching records instead. It would save you a few iterations I think.

    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 '!!REMOVE THIS!!
        RS_CurrDocTbl.Move (lngID1)    'move to 1st rec currently being worked on - Suspect there is a better way of doing this.

A couple of lines down from there, you're creating a comma delimited string of Field Names.

        ' 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

This executes for each record in the table. You only need to do this once; outside of the loop.

...and then you split it onto an array. Which I guess is ok because you don't want to check the first or last records for some reason. There's something smelly here, but I don't see how to fix it. Maybe another reviewer can comment on that.

Now we're into the third loop. Again, There's no reason to .movefirst. Just call RS_CurrDocTbl.Move (lngID2).

I can't quite figure out what you're doing here, but you probably want a series of SQL delete & update statements instead.

                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

Something like:

Insert foo,bar Into tmpTblDocsOutList Where ...

And

Delete tmpTblDocsOutList
From tmpTblDocsOutList docs1
Inner Join tmpTblDocsOutList docs2
    On docs1.key = docs2.key
Where ....

I'm sorry. I just can't follow the logic well enough to give you a query closer to what you'll actually need. You might also want to consider creating a new temp table to insert data into temporarily. Once you have that the way you want it, you can delete all of the records from tmpDocsOutList instead of trying to preserve just one record.