Please help me to be more efficient and concise!

S

SalmonDB

Registered User.
Local time
Today, 08:45
Joined
Dec 5, 2012
Messages
17
Hi everyone.

My code is working, but I'm new to vba, and I'm sure there are better ways to do this. The code is very repetitive and I think if I had a better understanding of writing functions and Do loops, I could make this code a lot simpler.

Basically, it takes the selected records, opens an excel spreadsheet, and fills in the details for vial labels in excel. Then it updates the status and records the date printed.

It gets tricky in that there are a bunch of If statements in order to catch problems, for example, the user should choose 4 collections to print at a time (the labels come in sheets of 80, and the collections are 100 samples each). But the user can continue with fewer than 4, although not with more. Also, if they've selected the wrong type of collection (which uses different labels) than the user is warned and the excel sheet closes.

Anyway, here's the code, it looks massive but it's mostly repetitive. Any constructive criticism much appreciated.

Thanks!
Erica

Code: 
Private Sub cmdPrint_Click()
Me.Form.Requery

'Step 1: Query all selected records
    Dim cnn2 As ADODB.Connection
    Set cnn2 = CurrentProject.Connection
            
    Dim rs2 As New ADODB.Recordset
    rs2.ActiveConnection = cnn2
    
    Dim SQL2 As String
    SQL2 = "SELECT qryAll_Collections.[Select], qryAll_Collections.Status, " & _
    "qryAll_Collections.CollectionType, qryAll_Collections.CollectionCode, qryAll_Collections.VialStart, " & _
    "qryAll_Collections.DatePrinted FROM qryAll_Collections WHERE ((qryAll_Collections.[Select])=True)"
    rs2.Open SQL2, cnn2, adOpenKeyset, adLockOptimistic
    
'Step 2: ensure the number of selected records is > zero
If rs2.EOF Then
        DoCmd.Beep
        MsgBox "Please select the collections you would like to print.", 0 Or 48, "Input Required"
        rs2.Close
        cnn2.Close
        Set rs2 = Nothing
        Set cnn2 = Nothing
        Exit Sub
End If

'Step 3: Move to first record and make sure it is the correct type (DNA kit, not Whatman sheet)
        rs2.MoveFirst

If rs2.Fields(2).Value = "DNA Kit" Then
        rs2.MoveLast
    
Else
        MsgBox "This button is for printing labels for DNA Kits. To print Whatman sheets return to 'DNA Kit prep' form." & vbNewLine & _
            vbNewLine & "To return to the 'DNA Kit Prep', click the button at the top of the page.", _
            0 Or 48, "Wrong Collection Type"
        rs2.Close
        cnn2.Close
        Set rs2 = Nothing
        Set cnn2 = Nothing
        Exit Sub
    
End If
        
'Step 4: Count the number of records, if there are more or less than 4, warn the user and close if there are more.
        Dim NX As Integer
        NX = rs2.RecordCount
        
        If NX < 4 Then
            Answer = MsgBox("You can print labels for up to 4 DNA Kits at one time, are you sure you want to continue?" & vbNewLine & _
            vbNewLine & "If you choose to continue, please note that the DNA label template is set up for 4 collections, so you must print pages separately to avoid printing blank sheets", _
            vbOKCancel + vbQuestion, "Proceed?")

            If Answer = vbCancel Then
            rs2.Close
            cnn2.Close
            Set rs2 = Nothing
            Set cnn2 = Nothing
            Exit Sub
            Else
            rs2.MoveFirst
            End If
            
        ElseIf NX > 4 Then
            MsgBox "Too many collections selected", 0 Or 48
            rs2.Close
            cnn2.Close
            Set rs2 = Nothing
            Set cnn2 = Nothing
            Exit Sub
        Else
            rs2.MoveFirst
        End If


'Step 6: Create an update SQL to update dates and status
    Dim cnn6 As ADODB.Connection
    Set cnn6 = CurrentProject.Connection
            
    Dim rs6 As New ADODB.Recordset
    rs6.ActiveConnection = cnn6
    
    Dim SQL6 As String
    SQL6 = "UPDATE tblDNA_Kit_Prep SET tblDNA_Kit_Prep.[Select] = False, tblDNA_Kit_Prep.DatePrinted = Date(), tblDNA_Kit_Prep.Status = 'Printed' WHERE ((tblDNA_Kit_Prep.[Select])=True)"

'Step 7: Open the excel file
        Dim DNAlabs As String
        DNAlabs = "C:\Users\jenkins\Desktop\Labelling_Templates\DNA_Kit_Labels.xlsm"
        
        Dim appexcel As Object
        Set appexcel = CreateObject("Excel.Application")
        appexcel.workbooks.Open DNAlabs
        
        appexcel.Visible = True
        
'Step 8: Enter the values into the excel spreadsheet, stop if any of the types are not 'DNA Kit' or if already printed
        '#--------------Collection #1--------------------#
        
        If IsNull(rs2.Fields(5).Value) Then
        
        'Collection Code #1
         appexcel.Range("A2").Select
         appexcel.activecell.Value = rs2.Fields(3).Value
        'Year #1
         appexcel.Range("A3").Select
         appexcel.activecell.Value = Format(Date, "yy")
         'Vialstart #1
         appexcel.Range("A4").Select
         appexcel.activecell.Value = rs2.Fields(4).Value
       
        Else
        appexcel.workbooks.Close
        MsgBox "It appears some of these labels have already been printed.", 0 Or 48, "Already Printed"
        rs2.Close
        cnn2.Close
        Set rs2 = Nothing
        Set cnn2 = Nothing
        Exit Sub
        End If

        rs2.MoveNext
        
        If rs2.EOF = True Then 'If y
        rs2.Close
        cnn2.Close
        Set rs2 = Nothing
        Set cnn2 = Nothing
        
        'Update Before Closing: Update the status of the Collections that are being printed
            DoCmd.SetWarnings False
            rs6.Open SQL6
            cnn6.Close
            Set rs6 = Nothing
            Set cnn6 = Nothing
            DoCmd.SetWarnings True
        
        Exit Sub
        
        ElseIf rs2.Fields(2) <> "DNA Kit" Then
        appexcel.workbooks.Close
        MsgBox "All Collections must be 'DNA Kit' type. To print whatman sheets return to 'DNA Kit Prep' form.", 0 Or 48, "Wrong Collection Type"
        rs2.Close
        cnn2.Close
        Set rs2 = Nothing
        Set cnn2 = Nothing
        appexcel.workbooks.Open DNAlabs
        Exit Sub
        
        End If
        
        '#--------------Collection #2--------------------#
        
        If IsNull(rs2.Fields(5).Value) Then
        
        'Collection Code #1
         appexcel.Range("A103").Select
         appexcel.activecell.Value = rs2.Fields(3).Value
        'Year #1
         appexcel.Range("A104").Select
         appexcel.activecell.Value = Format(Date, "yy")
         'Vialstart #1
         appexcel.Range("A105").Select
         appexcel.activecell.Value = rs2.Fields(4).Value
       
        Else
        appexcel.workbooks.Close
        MsgBox "It appears some of these labels have already been printed.", 0 Or 48, "Already Printed"
        rs2.Close
        cnn2.Close
        Set rs2 = Nothing
        Set cnn2 = Nothing
        Exit Sub
        End If

        rs2.MoveNext
        
        If rs2.EOF = True Then 'If y
        rs2.Close
        cnn2.Close
        Set rs2 = Nothing
        Set cnn2 = Nothing
        'Update Before Closing: Update the status of the Collections that are being printed
            DoCmd.SetWarnings False
            rs6.Open SQL6
            cnn6.Close
            Set rs6 = Nothing
            Set cnn6 = Nothing
    
    DoCmd.SetWarnings True
        Exit Sub
        
        ElseIf rs2.Fields(2) <> "DNA Kit" Then
        appexcel.workbooks.Close
        MsgBox "All Collections must be 'DNA Kit' type. To print whatman sheets return to 'DNA Kit Prep' form.", 0 Or 48, "Wrong Collection Type"
        rs2.Close
        cnn2.Close
        Set rs2 = Nothing
        Set cnn2 = Nothing
        Exit Sub
        
        End If
        
        '#--------------Collection #3--------------------#
        
        If IsNull(rs2.Fields(5).Value) Then
        
        'Collection Code #1
         appexcel.Range("A204").Select
         appexcel.activecell.Value = rs2.Fields(3).Value
        'Year #1
         appexcel.Range("A205").Select
         appexcel.activecell.Value = Format(Date, "yy")
         'Vialstart #1
         appexcel.Range("A206").Select
         appexcel.activecell.Value = rs2.Fields(4).Value
       
        Else
        appexcel.workbooks.Close
        MsgBox "It appears some of these labels have already been printed.", 0 Or 48, "Already Printed"
        rs2.Close
        cnn2.Close
        Set rs2 = Nothing
        Set cnn2 = Nothing
        Exit Sub
        End If

        rs2.MoveNext
        
        If rs2.EOF = True Then 'If y
        rs2.Close
        cnn2.Close
        Set rs2 = Nothing
        Set cnn2 = Nothing
        'Update Before Closing: Update the status of the Collections that are being printed
            DoCmd.SetWarnings False
            rs6.Open SQL6
            cnn6.Close
            Set rs6 = Nothing
            Set cnn6 = Nothing
            DoCmd.SetWarnings True
        Exit Sub
        
        ElseIf rs2.Fields(2) <> "DNA Kit" Then
        appexcel.workbooks.Close
        MsgBox "All Collections must be 'DNA Kit' type. To print whatman sheets return to 'DNA Kit Prep' form.", 0 Or 48, "Wrong Collection Type"
        rs2.Close
        cnn2.Close
        Set rs2 = Nothing
        Set cnn2 = Nothing
        Exit Sub
        
        End If
        
        '#--------------Collection #4--------------------#
        
        If IsNull(rs2.Fields(5).Value) Then
        
        'Collection Code #1
         appexcel.Range("A305").Select
         appexcel.activecell.Value = rs2.Fields(3).Value
        'Year #1
         appexcel.Range("A306").Select
         appexcel.activecell.Value = Format(Date, "yy")
         'Vialstart #1
         appexcel.Range("A307").Select
         appexcel.activecell.Value = rs2.Fields(4).Value
       
        Else
        appexcel.workbooks.Close
        MsgBox "It appears some of these labels have already been printed.", 0 Or 48, "Already Printed"
        rs2.Close
        cnn2.Close
        Set rs2 = Nothing
        Set cnn2 = Nothing
        Exit Sub
        End If

        rs2.MoveNext
        
        If rs2.EOF = True Then 'If y
        rs2.Close
        cnn2.Close
        Set rs2 = Nothing
        Set cnn2 = Nothing
        'Update Before Closing: Update the status of the Collections that are being printed
    DoCmd.SetWarnings False
            rs6.Open SQL6
            cnn6.Close
            Set rs6 = Nothing
            Set cnn6 = Nothing
            DoCmd.SetWarnings True
        Exit Sub
        
        ElseIf rs2.Fields(2) <> "DNA Kit" Then
        appexcel.workbooks.Close
        MsgBox "All Collections must be 'DNA Kit' type. To print whatman sheets return to 'DNA Kit Prep' form.", 0 Or 48, "Wrong Collection Type"
        rs2.Close
        cnn2.Close
        Set rs2 = Nothing
        Set cnn2 = Nothing
        appexcel.workbooks.Open DNAlabs
        Exit Sub
        
        End If
         
        rs2.Close
        cnn2.Close
        Set rs2 = Nothing
        Set cnn2 = Nothing

End Sub
 
You must log in or register to reply here.

Similar threads

F
Solved Add result from one function to another export function
Replies
18
Views
1,442
FoolzRailer
F
D
Solved Referencing a field within a RecordSet...
2
Replies
23
Views
1,398
cheekybuddha
cheekybuddha
klsblues
VBA Conditional Formatting error because I have more than 3 formatting requirements.
2 3
Replies
53
Views
2,022
AHeyne
A
T
Any Improvements to be made?
2
Replies
39
Views
2,249
tmyers
T
oxicottin
Solved Import from excel and delete unwanted data
Replies
14
Views
773
oxicottin
oxicottin

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Back
Top Bottom