I need to process some data which is the output from a CAD system, namely a Bill of Materials.
I've constructed database and written some VBA code to achieve this. An explanation of what this code does is included as comments at the top of the code block below.
This is my first project in Access/VBA and I have expanded upon something which a colleague wrote, so I expect it's pretty awful, but it does work for what I want it to do.
I've just posted one module which does the first step described in the comments block at the start of the code below.
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.
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.
Sub condenseOutputDocs() 'If gcfHandleErrors Then On Error GoTo Err_General Dim strCOMP_NAME As String Dim strDfltParam As String Dim strParamsExpOld As String Dim strParamsExpNew As String Dim intParamPos As Integer Dim strREF1 As String Dim intNB1 As Integer Dim strCOMP_NAME1 As String Dim strPAR1 As String Dim strREF2 As String Dim strREFnew As String Dim intNB2 As Integer Dim strCOMP_NAME2 As String Dim strPAR2 As String Dim strCOMMENT1 As String Dim strCOMMENT2 As String Dim strCOMMENTnew As String Dim lngCmntFndPos As Long Dim intSlashCount As Integer Dim intCommaCount As Integer Dim strCmntPrefix 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 '------------------------------------------------------------------------------------ ' 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] ' '------------------------------------------------------------------------------------- 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 comstructed earlier in another sub. Do While Not RS_tmpTblDocsOutList.EOF ' loop through output docs strDocOut = RS_tmpTblDocsOutList![OUT_DOCUMENT] & "" 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 = "" str1stRecContents = "" str2ndRecContents = "" 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) & "" ' append the field's contents to the string Next strREF1 = RS_CurrDocTbl![REF] & "" If strREF1 = "" Then 'if ref is blank strREF1 = "¿" ' replace with special flag character for later processing End If intNB1 = RS_CurrDocTbl![NB] ' each record will ALWAYS have a NB - will be an int, usually no more than ~60 strCOMMENT1 = RS_CurrDocTbl![COMMENT] & "" If strCOMMENT1 & "" = "" Then strCOMMENT1 = "¿" ' if comment is blank then replace with special flag character End If If Right(strCOMMENT1, 1) <> "~" Then ' if comment does not already contain some comment (from a previous run through) then create new concatenated string strCOMMENT1 = strREF1 & "~" & intNB1 & "~" & strCOMMENT1 & "~" ' e.g. "A~3~Cable groove~" End If 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 While Not RS_CurrDocTbl.EOF '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 = "" ' 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) & "" ' append its contents to the string Next strREF2 = RS_CurrDocTbl![REF] & "" If strREF2 = "" Then ' if ref is blank strREF2 = "¿" ' replace with key character for later processing End If intNB2 = RS_CurrDocTbl![NB] strCOMMENT2 = RS_CurrDocTbl![COMMENT] & "" If strCOMMENT2 = "" Then ' if comment is blank strCOMMENT2 = "¿" ' replace with key character for later processing End If If Right(strCOMMENT2, 1) <> "~" Then strCOMMENT2 = strREF2 & "~" & intNB2 & "~" & strCOMMENT2 & "~" ' e.g. "A~3~Cable groove~" End If 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 ' 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