1
\$\begingroup\$

I have a macro in Excel that updates a recordset using WHERE a primary key in MS Access matches a primary key in a UserForm label value. The macro is called from a Userform command button, this command button also writes about 10 different UserForm textbox values back to MS ACCESS and to a Sheet in Excel. My query in MS ACCESS is using PARAMETERS as well.

I find that at times my UPDATE query takes a little longer to run, and Excel will freeze. Experts, is there anything missing from my code that I should be executing?

UPDATE SQL MACRO

Sub ClientUpdate ()
Dim db As Database
Dim qdf As QueryDef

Application.StatusBar = "Connecting to PBS Database......"
Set db = OpenDatabase("M:\Admin Vision\PBS BackUP Database\Database15.mdb")
Set qdf = db.QueryDefs("pbsupdate")

Application.StatusBar = "Uploading Client Data to PBS server...."
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

    qdf!pbskey = dialer.key
    qdf!pbsclient = dialer.client
    qdf!pbspriority = dialer.priority_
    qdf!pbssource = dialer.priority
    qdf!pbslastcontact = dialer.contact
    qdf!pbsresult = dialer.result
    qdf!pbsnextsteps = dialer.segmentType
    qdf!pbsattempts = dialer.Label11 + 1
    qdf!pbsnotes = dialer.notes

 Application.CalculateUntilAsyncQueriesDone

         qdf.Execute dbFailOnError

qdf.Close
db.Close
Application.StatusBar = "Upload Successful!"

Set qdf = Nothing
Set cdb = Nothing

Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

USERFORM CODE

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False      
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

Dim wb As Workbook: Set wb = ThisWorkbook
Dim Ws As Worksheet: Set Ws = wb.Sheets("clientmenu")
Dim lastrow As Long
Dim CellRow As Integer    ' create a variable to hold the cell row

CellRow = ActiveCell.Row
x = Me.lblRow
CurrentRow = ActiveCell.Row


    If contact.Value <> "" And result.Value = vbNullString Then
        MsgBox "Please enter a result"
        result.BorderColor = vbRed
        result.BackColor = vbYellow
        result.DropDown

    Exit Sub

    ElseIf contact.Value = vbNullString And result.Value <> "" Then

        MsgBox "Please enter a date"
        contact.BorderColor = vbRed
        contact.BackColor = vbYellow

Exit Sub
End If

    ClientUpdate '///calling UPDATE SQL MACRO

    Unload Me

With Sheet3
lastrow = Sheet3.Range("A" & Rows.Count).End(xlUp).Row + 1

If Me.priority_ = vbNullString Then

    .Cells(x, 2).Interior.Color = vbWhite
    .Cells(x, 2).Font.Color = RGB(0, 0, 0)

ElseIf Me.priority_ = "None" Then 

    .Cells(x, 2).Interior.Color = vbWhite
    .Cells(x, 2).Font.Color = RGB(0, 0, 0)
    .Cells(x, 3).Value = vbNullString


ElseIf Me.priority_ = "High" Then


    .Cells(x, 2) = Me.priority_.Text
    ElseIf Me.priority_ = "Medium" Then


    .Cells(x, 2) = Me.priority_.Text
    ElseIf Me.priority_ = "Low" Then


    .Cells(x, 2) = Me.priority_.Text

End If

        .Cells(x, 2) = Me.client.Text
        .Cells(x, 4) = Me.priority.Text
        .Cells(x, 9) = Me.notes.Text
        .Cells(x, 7) = Me.segmentType.Text

If Me.contact.Value = vbNullString Then

    Exit Sub
Else

    .Cells(x, 5) = Me.contact.Value

End If

    .Cells(x, 6) = Me.result.Text

If Me.contact = vbNullString Then

    ElseIf Me.contact <> vbNullString Then

    .Cells(x, 8) = .Cells(x, 8) + 1

End If

    End With

    callbyMonth 'filters call by months
    callsByDay  'filters calls by day
    callsByWeek 'filters calls by week

Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub
\$\endgroup\$
2
  • \$\begingroup\$ you have a very dangerous habit of exiting subs before turning screen things back on. \$\endgroup\$
    – Doug Coats
    Commented Nov 21, 2019 at 20:18
  • 1
    \$\begingroup\$ @doug coats agreed. Also I write my VBA code much differently now. Looking back at this post, my code is a spaghetti mess \$\endgroup\$
    – PP8
    Commented Nov 21, 2019 at 22:56

0

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Browse other questions tagged or ask your own question.