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\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.