Updating access records

Question

I spent an hour or so this morning compiling this, and since I have started reading Clean Code and The Pragmatic Programmer I figured I would let you help me get slightly better at this.

Due to some crappy limitations with the specifics I was forced to work in Excel VBA instead of Access (someone doesn't want to build tables for the two lists in the Excel sheet).

The code pulls a list of defects from a production table, checks a master list to see if it ever existed, then checks an open list to see if it's current and updates the table accordingly. This could be super easy and potentially 100% automated if they would make tables for the two lists. The log of what was found per defect# (writing to sheet) is something I added just in case they want a log.

Private Sub thisbetheshitmane()
    Dim db As DAO.Database
    Dim rst As DAO.Recordset
    Dim vAr As String
    Dim i As Integer
    Dim y As Integer
    Dim InCombined As Boolean
    Dim InOpen As Boolean

    Set db = DBEngine.OpenDatabase("C:\Users\dzcoats\Documents\Microsoft.accdb")
    Set rst = db.OpenRecordset("SELECT DISTINCT [VDefects].Defect FROM [VDefects] WHERE [VDefects].Defect IS NOT NULL;")

    Dim QResult() As Variant
    QResult = rst.GetRows(rst.RecordCount)
    For a = LBound(QResult, 2) To UBound(QResult, 2)
        vAr = QResult(0, a)
        Debug.Print ; vAr
    Next a

    Dim CombinedList() As Variant
    CombinedList = Application.Transpose(Worksheets(1).Range("b2:b2000").Value)
    Dim OpenList() As Variant
    OpenList = Application.Transpose(Worksheets(1).Range("a2:a2000").Value)

    For y = LBound(QResult, 2) To UBound(QResult, 2)
        vAr = Trim(QResult(0, y))
        InCombined = False

        For a = LBound(CombinedList) To UBound(CombinedList)
            If vAr = CombinedList(a) Then InCombined = True
        Next a

        InOpen = False

        For a = LBound(OpenList) To UBound(OpenList)
            If vAr = OpenList(a) Then InOpen = True
        Next a

        If vAr <> "Defect" And vAr <> vbNullString And vAr <> "" Then

            If InCombined = False And InOpen = False Then
                set rst = db.OpenRecordSet ("UPDATE [VDefects] SET [VDefects].Status ='Bad Defect Number' WHERE ((([VDefect].Defect)='"& vAr &"'));")
                Debug.Print "BAD "; vAr
                ThisWorkbook.Sheets("Sheet2").Cells(Sheet2.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = "Bad"
                ThisWorkbook.Sheets("Sheet2").Cells(Sheet2.Rows.Count, 1).End(xlUp).Offset(0, 1).Value = vAr
            End If

            If InCombined = True And InOpen = False Then
                set rst = db.OpenRecordSet ("UPDATE [VDefects] SET [VDefects].Status ='Completed' WHERE ((([VDefects].Defect)='"& vAr &"'));")
                Debug.Print "CLOSED "; vAr
                ThisWorkbook.Sheets("Sheet2").Cells(Sheet2.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = "Closed"
                ThisWorkbook.Sheets("Sheet2").Cells(Sheet2.Rows.Count, 1).End(xlUp).Offset(0, 1).Value = vAr
            End If

            If InCombined = True And InOpen = True Then
                Debug.Print "OPEN "; vAr
                ThisWorkbook.Sheets("Sheet2").Cells(Sheet2.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = "Open"
                ThisWorkbook.Sheets("Sheet2").Cells(Sheet2.Rows.Count, 1).End(xlUp).Offset(0, 1).Value = vAr
            End If
        End If
    Next y

    rst.Close
    Set rs = Nothing
    db.Close
    Set db = Nothing

End Sub

Answer 1

Here is the code refined using these features:

• rst.Filter
• rst.Update
• Scripting.Dictionary
• Range("A1").CopyFromRecordset rst

---

Sub ThisBeTheShitMane()
    Const DBPath = "C:\Users\dzcoats\Documents\Microsoft.accdb"
    Const DebugMode As Boolean = False

    Dim db As DAO.Database
    Dim rst As DAO.Recordset
    Dim key As String
    Dim vAr
    Dim d As Object: Set d = CreateObject("Scripting.Dictionary")

    Set db = DBEngine.OpenDatabase(DBPath)
    Set rst = db.OpenRecordSet("SELECT [VDefects].Defect, [VDefects].Status FROM [VDefects] WHERE [VDefects].Defect IS NOT NULL;")

    'Combined List
    With Worksheets(1)
        For Each vAr In .Range("B2", .Range("B" & .Rows.Count).End(xlUp)).Value
            key = vAr
            d(key) = "Completed"
        Next
    End With

    'Open List
    With Worksheets(1)
        For Each vAr In .Range("A2", .Range("A" & .Rows.Count).End(xlUp)).Value
            key = vAr
            If d.Exists(key) Then
                d(key) = "OPEN"
            Else
                If DebugMode Then Debug.Print "vAr: "; vAr, "ID is in the Open List but is missing from the Combined List "
            End If
        Next
    End With

    With rst
        .MoveFirst
        Do Until .EOF
            key = ![Defect]
            .Edit
            ![Status] = IIf(d.Exists(key), d(key), "Bad Defect Number")
            .Update
            .MoveNext
        Loop
        .MoveFirst
    End With

    Worksheets("Sheet2").Range("A1").CopyFromRecordset rst

    rst.Close
    Set rst = Nothing
    db.Close
    Set db = Nothing

End Sub

But we could just let the database do the work for us by converting the Open and Combined list into a comma separated values list and using IN() to check the values. If [Defect] is a text field you will has to wrap the values in quotes.

Sample Query:

UPDATE VDefects SET VDefects.Status = IIf([VDefects]![Defect] NOT IN (1,2,3,4,5,6) And [VDefects]![Defect] NOT IN (4,5,6,7,8,9),'Bad Defect Number',IIf([VDefects]![Defect] NOT IN (1,2,3,4,5,6),'Completed','OPEN'));

---

Sub JustDoIt()
    Const DBPath = "C:\Users\best buy\Desktop\Microsoft.accdb"
    Dim db As DAO.Database: Set db = DBEngine.OpenDatabase(DBPath, , True)
    Dim rst As DAO.Recordset
    Dim sSQL As String, t1 As String, t2 As String
    Dim arr1 As Variant, arr2 As Variant

    With Sheet1
        t1 = getValueList(.Range("A2", .Range("A" & rows.Count).End(xlUp)), False)
        t2 = getValueList(.Range("B2", .Range("B" & rows.Count).End(xlUp)), False)
    End With

    sSQL = "UPDATE VDefects SET VDefects.Status = IIf([VDefects]![Defect] NOT IN (" & t1 & ") And [VDefects]![Defect] NOT IN (" & t2 & "),'Bad Defect Number',IIf([VDefects]![Defect] NOT IN (" & t1 & "),'Completed','OPEN'));"

    db.Execute sSQL

    Set rst = db.OpenRecordSet("SELECT [VDefects].Defect, [VDefects].Status FROM [VDefects] WHERE [VDefects].Defect IS NOT NULL;")
    Worksheets("Sheet2").Range("A1").CopyFromRecordset rst

    rst.Close
    Set rst = Nothing
    db.Close
    Set db = Nothing
End Sub

Function getValueList(Target As Range, WrapInQuotes) As String
    Dim arr As Variant
    arr = Application.TRanspose(Target.Value)

    If WrapInQuotes Then
        getValueList = Join(arr, """,""") & """"
    Else
        getValueList = Join(arr, ",")
    End If
End Function

---

Answer 2

I also added this to help with in the event non numerics are falsley entered in the UI that inputs data into the DB (again another reason why I wish they'd implement new tables and better db design lol)

       If Not IsNumeric(vAr) Then
            InCombined = True
            InOpen = True
        Else
            InCombined = IsError(Application.Match(CLng(vAr), vArray, 0))
            InOpen = IsError(Application.Match(CLng(vAr), vArray2, 0))
        End If

after some prelim testing- this removes the need for either loop seeing in how everything is a number but stored into the table as text (eye roll)