I've written some code in VBA to help our R&D department. I've moved all of the redundant and static information into a database for them to look up and then generate a report from.
I've attached the btn_OK_Click()
Sub from my user form. Once the user clicks the button, the form goes through the list of "Processes" that the user selects from a Listview
control in the form. Once it gets the list of processes, it then queries the SS DB to get the pertinent information.
The code works, but when it starts getting into the range of 30 or more "Processes", it slows down. I think it has something to do with how I'm looping through the processes.
Below is the btn_OK_Click()
from my Userform and My Process
class. Please let me know if I've coded the SQL code as efficiently as I could have.
Private Sub btn_OK_Click()
'get confirmation
If MsgBox("Generate Hazard Analasys?", vbYesNo, "Confirm") = vbCancel Then
Unload Me
Exit Sub
End If
'Set up the connection
Set HazardConn = New Connection
Set HazardSet = New Recordset
'Open the connection to the database
On Error GoTo FORMCONNECTIONERROR
HazardConn.Open CONNSTRING
On Error GoTo 0
'Declare Variables
Dim SQLstring As String 'SQL Command, to be built and passed to the database
Dim processIDs As Collection 'List of process names to be appended to the SQL String
Dim procID As Variant 'Individual Process Name
Dim hazardList As ListObject 'Table (Found in the "Hazard Analysis" Worksheet)
Dim newProcess As Process 'Process Class - holds all relevant Process attributes
Dim selRow As Long 'Individual row in the ListView of the form
'Disable Screen updating, calculation and events
OptimizeSpeed
'Initialize
Set processIDs = New Collection
On Error GoTo TABLENOTFOUNDERROR
Set hazardList = HazardSheet.ListObjects("tbl_Hazard")
On Error GoTo 0
'Reset the List
On Error Resume Next
hazardList.DataBodyRange.Rows.Delete
On Error GoTo 0
'Initialize the SQL String
SQLstring = "SELECT * FROM dbo.Hazard_List WHERE ProcessName IN("
'Append the SQL String and list the Process Names
On Error GoTo GENERATEDLISTERROR
With Me.list_Generated
For selRow = 0 To Me.list_Generated.ListCount - 2
SQLstring = SQLstring & "'" & .List(selRow) & "', "
processIDs.Add .List(selRow)
Next selRow
SQLstring = SQLstring & "'" & .List(selRow) & "')"
processIDs.Add .List(selRow)
End With
On Error GoTo 0
'Open the RecordSe
On Error GoTo FORMCONNECTIONERROR
HazardSet.Open SQLstring, HazardConn, adOpenStatic, adLockOptimistic, adCmdText
On Error GoTo 0
'Add the Processes to the Hazard Analysis Table
For Each procID In processIDs
'Initialize the Process class
Set newProcess = New Process
newProcess.ProcessID = procID
'Filter the recordset by the Process Name
HazardSet.Filter = "ProcessName = '" & procID & "'"
'Loop through the filtered records to append all hazards and risks to the Process class
On Error GoTo RECORDSETREADERROR
HazardSet.MoveFirst
Do Until HazardSet.EOF
'Declare local variables
Dim hazType As String 'Hazard type (Biological, Chemical, Physical)
Dim hazName As String 'Description of the hazard
Dim hazRisk As Boolean 'Indicates if the hazard is a risk
Dim hazJustify As String 'Justification for the hazard risk
Dim hazPrevent As String 'Control Measures applied to the hazard
Dim ccp As Boolean 'CCP Indicator
'Initialize local variables
hazType = Mid(CStr(HazardSet("HazardType").Value), 1, 1)
hazName = HazardSet("HazardName")
hazRisk = IIf(IsNull(HazardSet("RiskToConsumer")) Or HazardSet("RiskToConsumer") = 0, False, True)
hazJustify = IIf(IsNull(HazardSet("Justification")), "", HazardSet("Justification"))
hazPrevent = IIf(IsNull(HazardSet("ControlMeasure")), "", HazardSet("ControlMeasure"))
ccp = IIf(IsNull(HazardSet("CCP")) Or HazardSet("CCP") = 0, False, True)
'Pass information into the Process class to be appended to its individual attributes
newProcess.AddHazard hazType, hazName, hazRisk, hazJustify, hazPrevent
HazardSet.MoveNext
Loop
On Error GoTo 0
'Add the entire process to the Hazard Table
On Error GoTo LOADTABLEERROR
With hazardList
.ListRows.Add
.ListColumns(2).DataBodyRange(.ListRows.Count).Value = newProcess.ProcessID
.ListColumns(3).DataBodyRange(.ListRows.Count).Value = newProcess.Hazards
.ListColumns(4).DataBodyRange(.ListRows.Count).Value = newProcess.Risks
.ListColumns(5).DataBodyRange(.ListRows.Count).Value = newProcess.Justifications
.ListColumns(6).DataBodyRange(.ListRows.Count).Value = newProcess.Preventions
.ListColumns(7).DataBodyRange(.ListRows.Count).Value = IIf(ccp, "Yes", "No")
.ListColumns(1).DataBodyRange(.ListRows.Count).EntireRow.AutoFit
End With
On Error GoTo 0
Next procID
'''''''''''''
'''CLEANUP'''
'''''''''''''
'Unload the form
Unload Me
'Dispose of the Connections
HazardSet.Close
HazardConn.Close
Set HazardSet = Nothing
Set HazardConn = Nothing
'Reenable screen updating, calculation and events
ResetApp
Exit Sub
'Connection error - Will exit the sub if we cannot connect to the database
FORMCONNECTIONERROR:
MsgBox "There was an error connecting to the database. Please consult your designated support professional", vbCritical, "Error"
Debug.Print "Connection Error: " & Err.Number & " - " & Err.Description
Set HazardConn = Nothing
Set HazardSet = Nothing
ResetApp
Exit Sub
'Table not found error - Will unload the form if the table has been renamed or deleted
TABLENOTFOUNDERROR:
MsgBox "The Table that houses all Processes has been either renamed or deleted. Please consult your designated support professional", vbCritical, "Error"
Debug.Print "Table Not Found Error: " & Err.Number & " - " & Err.Description
Set HazardConn = Nothing
Set HazardSet = Nothing
ResetApp
Unload Me
Exit Sub
'Generated List Error - Will exit the sub if the Generated List is blank, or throws some other errors
GENERATEDLISTERROR:
MsgBox "Error getting generated list", vbExclamation, "Error"
Debug.Print "Generated List Error: " & Err.Number & " - " & Err.Description
Set HazardConn = Nothing
Set HazardSet = Nothing
ResetApp
Exit Sub
'Recordset reading error - Will exit the sub if there was an issue reading the SQL Query
RECORDSETREADERROR:
MsgBox "There was an error loading the Processes. Please consult your designated support professional", vbCritical, "Error"
Debug.Print "Recordset Error: " & Err.Number & " - " & Err.Description
Set HazardConn = Nothing
Set HazardSet = Nothing
ResetApp
Exit Sub
'Load table error - Will exit the sub if there was an issue loading the table
LOADTABLEERROR:
MsgBox "There was an error filling the table", vbCritical, "Error"
Debug.Print "Load Table Error: " & Err.Number & " - " & Err.Description
Set HazardConn = Nothing
Set HazardSet = Nothing
ResetApp
Exit Sub
End Sub
Process
Class:
Private procID As String
Private hazardString As String
Private riskString As String
Private justString As String
Private preventString As String
Private procCCP As Boolean
Private bioCount As Long
Private chemCount As Long
Private physCount As Long
Public Property Get ProcessID() As String
ProcessID = procID
End Property
Public Property Let ProcessID(val As String)
procID = val
End Property
Public Property Get Hazards() As String
Hazards = hazardString
End Property
Public Property Let Hazards(val As String)
hazardString = val
End Property
Public Property Get Risks() As String
Risks = riskString
End Property
Public Property Let Risks(val As String)
riskString = val
End Property
Public Property Get Justifications() As String
Justifications = justString
End Property
Public Property Let Justifications(val As String)
justString = val
End Property
Public Property Get Preventions() As String
Preventions = preventString
End Property
Public Property Let Preventions(val As String)
preventString = val
End Property
Public Property Get ccp() As Boolean
ccp = procCCP
End Property
Public Property Let ccp(val As Boolean)
procCCP = val
End Property
Public Sub Init(id As String, c As Boolean)
procID = id
bioCount = 0
chemCount = 0
physCount = 0
procCCP = c
End Sub
Public Sub AddHazard(hazType As String, hazName As String, hazRisk As Boolean, hazJustify As String, hazPrevent As String)
Dim hazRiskString As String
Dim cString As String
Dim cCount As Long: cCount = 0
Dim newLine As Boolean
hazRiskString = IIf(hazRisk, "Yes", "No")
newLine = True
Select Case hazType
Case "B":
bioCount = bioCount + 1
cCount = bioCount
Case "C":
chemCount = chemCount + 1
cCount = chemCount
Case "P":
physCount = physCount + 1
cCount = physCount
newLine = False
End Select
cString = hazType & cCount
appendStrings cString, hazName, hazRiskString, hazJustify, hazPrevent, newLine
End Sub
Private Sub appendStrings(catString As String, hazName As String, hazRiskString As String, hazJustify As String, hazPrevent As String, addNewLine As Boolean)
Dim newLine As String: newLine = IIf(addNewLine, vbNewLine, "")
If Not hazName = "None Identified" Then
hazardString = hazardString & catString & " - " & hazName & newLine
riskString = riskString & catString & " - " & hazRiskString & newLine
If Not hazJustify = vbNullString Then
justString = justString & catString & " - " & hazJustify & newLine
End If
If Not hazPrevent = vbNullString Then
preventString = preventString & catString & " - " & hazPrevent & newLine
End If
End If
End Sub
HazardConn
connection andHazardSet
recordset variables are all global \$\endgroup\$ – jDave1984 Feb 15 '18 at 15:18processIDs
from a Collection to a Scripting Dictionary. You would then add theprocID
as a key andnewProcess
as the value. In this way, you could lookup thenewProcess
by itsprocID
. If you go this route it would be advantages to change the Recordset 's CursorType toadOpenForwardOnly
. \$\endgroup\$ – user109261 Feb 15 '18 at 20:31adOpenForwardOnly
\$\endgroup\$ – jDave1984 Feb 15 '18 at 20:37