Why does my vba userform crash when clicking save button?

Question

I have a vba userform created in excel I'm using as a front end user data collection interface. The userform reads/writes to an access db i have stored on the local network.

The users (multiple workstation) are running Office 2010 and Office 2016. So far I have not got this working on any other computer other than my own.

When opening the workbook the userform loads fine, they enter the data, then click save. When they click save the form hangs a few seconds then just closes. Nothing else happens after.

I know using an access form would be the better option here but unfortunately my company isn't very big and only purchased the licence for myself.

I'm definitely not an expert with vba and im sure my code is sloppy so any constructive feedback is greatly appreciated.

Below is my userform code:

Private Sub UserForm_Initialize() 'Sets variables when the userfom initializes

Call MakeFormResizeable(Me)

Me.tbDate.Value = Format(Now(), "mm/dd/yyyy hh:mm")

Call List_box_Data


End Sub

Private Sub tbTotalPartsComplt1_Change()

Dim ssheet As Worksheet
Dim lastrow As Long
'Dim ussheet As Worksheet

Set ssheet = ThisWorkbook.Sheets("DATATEMP")
'Declare what cells on above worksheets to collect data
nr = ssheet.Cells(Rows.Count, 1).End(xlUp).Row + 1

'us = ussheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
lastrow = Cells(Rows.Count, "A").End(xlUp).Row

'Data captured on DATATEMP page
ssheet.Cells(nr, 1) = Me.cboHour1
ssheet.Cells(nr, 2) = tbDate
ssheet.Cells(nr, 3) = Me.cboEmployeeName
ssheet.Cells(nr, 4) = Me.cboWorkArea
ssheet.Cells(nr, 5) = Me.cboPartNum1.Value
ssheet.Cells(nr, 6) = Me.tbWorkOrder1.Value
ssheet.Cells(nr, 7) = Me.cboOpDesc1
ssheet.Cells(nr, 10) = Me.tbStdMin1.Value
ssheet.Cells(nr, 11) = Me.tbTotalPartsComplt1.Value
ssheet.Cells(nr, 12) = Me.lblPartTotalStdMins1.Caption
ssheet.Cells(nr, 13) = Me.cboAreaSup
ssheet.Cells(nr, 14) = Me.tbLostTime1 'Lost time mins
ssheet.Cells(nr, 15) = Me.cboLostTime1 'Lost time code
ssheet.Cells(nr, 16) = Me.cboShift 'Shifts 1st or 2nd
ssheet.Cells(nr, 17) = Me.cboPermTemp 'Employee Permanent or Temp hire
ssheet.Cells(nr, 18) = Me.cboShiftStart1 'Shift start time
ssheet.Cells(nr, 19) = Me.cboShiftEnd1 ' Shift end time
ssheet.Cells(nr, 20) = Me.tbNotes



' Multiply the values in Standard Mins box and Parts Completed Box to send to Label
Sum = Val(tbStdMin1.Text) * Val(tbTotalPartsComplt1.Text)
Summ = Val(tbStdMin1.Text) * Val(tbTotalPartsComplt1.Text)
Sum2 = Val(tbTotalPartsComplt1.Text) '+ Val(tbTotalPartsComplt2.Text) + Val(tbTotalPartsComplt3.Text) + Val(tbTotalPartsComplt4.Text) + Val(tbTotalPartsComplt5.Text) + Val(tbTotalPartsComplt6.Text) + Val(tbTotalPartsComplt7.Text) + Val(tbTotalPartsComplt8.Text) + Val(tbTotalPartsComplt9.Text) + Val(tbTotalPartsComplt10.Text) + Val(tbTotalPartsComplt11.Text) + Val(tbTotalPartsComplt12.Text)
'Sum3 = Val(lblPartTotalStdMins1.Caption)
Sum4 = Val(tbLostTime1.Text) + Val(tbLostTime2.Text)


lblPartTotalStdMins1.Caption = Sum ' Standard mins label
lblTotalPartsComp.Caption = Sum2 ' TOTAL parts completed label
lblTotalLostMins.Caption = Sum4
lblPartTotalStdMins.Caption = Summ



End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  If CloseMode = vbFormControlMenu Then
    Cancel = True
    MsgBox "Please use the Close Form button!"
  End If
End Sub

Private Sub UserForm_Resize()

    Call AdjustSizeOfControls

End Sub

'*''*'''''''''''''''''''''''''''''''''*''*'
'*''*'BUTTON CONTROLS BELOW THIS LINE'*''*'
'*''*'''''''''''''''''''''''''''''''''*''*'

Private Sub btnClose1_Click()
'Application.Visible = True
Unload Me
ThisWorkbook.Close
Application.Quit
'DailyOpLogMain.Hide


End Sub
'*'''''''''''''''''''
'*''  HELP BUTTON   '
'*'''''''''''''''''''
'Sends email for feedback/comments/suuport ([email protected],[email protected])
Private Sub btnHelp_Click()

Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    On Error Resume Next
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    xMailBody = "REF: TIME MATRIX APP" & vbNewLine & vbNewLine & _
              "Have Some Feedback or Suggestions? Great! We Love Feedback!" & vbNewLine & _
              "Having Problems Navigating or Need Support With The App? We Can Help!" & vbNewLine & _
              "Write/Comment Below and we will get in touch!" & vbNewLine & _
              "" & vbNewLine & _
              "" & vbNewLine & _
              "**BEGIN MESSAGE BELOW**"

                  On Error Resume Next
    With xOutMail
        .To = "[email protected];[email protected]"
        .CC = ""
        .BCC = ""
        .Subject = "Daily Operator Log"
        .Body = xMailBody
        .Display   'or use .Send
    End With
    On Error GoTo 0
    Set xOutMail = Nothing
    Set xOutApp = Nothing


End Sub


'*'''''''''''''''*'
'*' RESET BUTTON'*'
'*'''''''''''''''*'
'Defines what data to erase/clear from cells/fields when clicking the "Clear All" Button

Private Sub btnReset_Click()

ClearAll Me

Me.cboHour1 = ""
Me.tbNotes = ""
Me.lblPartTotalStdMins1 = "0"

'Me.lblTotalStandardMins.Caption = "0"
Me.lblTotalPartsComp.Caption = "0"

Worksheets("DATATEMP").Range("A3:P137").ClearContents

ReloadDateTime

End Sub


'*'''''''''''''''*'
'*' SAVE BUTTON'*'
'*'''''''''''''''*'



Private Sub btnSave_Click()
Application.EnableCancelKey = xlDisabled


'Check and validate there are no empty entries
    If Me.cboEmployeeName.Value = "" Then
        MsgBox "Please enter the Employee Name", vbCritical
        Exit Sub
    End If

        If Me.cboWorkArea.Value = "" Then
        MsgBox "Please enter the Work Area", vbCritical
        Exit Sub
    End If

        If Me.cboAreaSup.Value = "" Then
        MsgBox "Please enter the Are Supervisor", vbCritical
        Exit Sub
    End If

        If Me.cboShiftStart1.Value = "" Then
        MsgBox "Please enter your shift start time", vbCritical
        Exit Sub
    End If

        If Me.cboShiftEnd1.Value = "" Then
        MsgBox "Please enter your shift end time", vbCritical
        Exit Sub
    End If

        If Me.cboHour1.Value = "" Then
        MsgBox "Please enter the hour number 1 thru 12", vbCritical
        Exit Sub
    End If

        If Me.cboPartNum1.Value = "" Then
        MsgBox "Please enter the part number", vbCritical
        Exit Sub
    End If

        If Me.tbWorkOrder1.Value = "" Then
        MsgBox "Please enter the job number", vbCritical
        Exit Sub
    End If

        If Me.cboOpDesc1.Value = "" Then
        MsgBox "Please enter the operation performed", vbCritical
        Exit Sub
    End If

        If Me.cboSeqNum1.Value = "" Then
        MsgBox "Please enter the sequence number", vbCritical
        Exit Sub
    End If

        If Me.cboOpNum1.Value = "" Then
        MsgBox "Please enter the operation number", vbCritical
        Exit Sub
    End If

        If Me.tbStdMin1.Value = "" Then
        MsgBox "Please enter standard minutes", vbCritical
        Exit Sub
    End If

        If Me.tbTotalPartsComplt1.Value = "" Then
        MsgBox "Please enter parts quantity", vbCritical
        Exit Sub
    End If

        If Me.tbTotalPartsComplt1.Value = "" Then
        MsgBox "Please enter parts quantity", vbCritical
        Exit Sub
    End If



Dim conn As New ADODB.Connection
Dim rs1 As New ADODB.Recordset
Dim connstring As String


#If Win64 Then
  conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=\\superform\production\_Working Folders\MASTER\DBbackend\ProductionTrimShop1.accdb"
#Else
  conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=\\superform\production\_Working Folders\MASTER\DBbackend\ProductionTrimShop1.accdb"
#End If

connstring = "Select * from TEST"

rs1.Open Source:=connstring, ActiveConnection:=conn, LockType:=adLockOptimistic

With rs1 'if new data record
.AddNew
.Fields("Date Time") = Me.tbDate 'date and time stamp
.Fields("Employee Name") = Me.cboEmployeeName 'employee name
.Fields("Work Area") = Me.cboWorkArea 'work area
.Fields("Part Number") = Me.cboPartNum1 'part number
.Fields("Hour") = Me.cboHour1 'hour of shift 1 thru 12
.Fields("Job Number") = Me.tbWorkOrder1 'job number
.Fields("Operation") = Me.cboOpDesc1 'operation being performed
.Fields("Sequence Number") = Me.cboSeqNum1 'sequence number
.Fields("Operation Number") = Me.cboOpNum1 'operation number
.Fields("Standard Mins") = Me.tbStdMin1 'standard mins to perform operation
.Fields("Parts Complete") = Me.tbTotalPartsComplt1 'total parts completed
.Fields("Total Std Mins") = Me.lblPartTotalStdMins1 'total of mins standard mins multipled by total number of parts completed
.Fields("Area Supervisor") = Me.cboAreaSup 'area supervisor
.Fields("Lost Time Mins") = Me.tbLostTime1 'total mins of lost time
.Fields("Lost Time Mins2") = Me.tbLostTime2 'total mins of lost time
.Fields("Lost Time Code") = Me.cboLostTime1 'lost time code
.Fields("Lost Time Code2") = Me.cboLostTime2
.Fields("Shift") = Me.cboShift 'shift being worked
.Fields("PermTemp") = Me.cboPermTemp 'employee status permanent hire or temp hire
.Fields("Shift Start") = Me.cboShiftStart1 'shift start time
.Fields("Shift End") = Me.cboShiftEnd1 'shift end time
.Fields("Notes") = Me.tbNotes 'notes or comments
.Update
.Close

End With

conn.Close

Application.DisplayAlerts = True
Application.ScreenUpdating = True

MsgBox "Data Submitted Successfully!"



'Clear contents of all fields on UI upon clicking save (indicator of all systems GO)
Me.cboSeqNum1 = ""
Me.cboOpNum1 = ""
'Me.cboShift = ""
Me.cboHour1 = ""
Me.tbDate = ""
'Me.cboEmployeeName = ""
'Me.cboWorkArea = ""
'Me.cboAreaSup = ""
Me.cboPartNum1 = ""
Me.cboOpDesc1 = ""
Me.cboSeqNum1 = ""
Me.cboOpNum1 = ""
Me.tbStdMin1 = ""
Me.tbNotes = ""
Me.cboLostTime1 = ""
Me.tbLostTime1 = ""
Me.tbWorkOrder1.Text = ""
Me.tbTotalPartsComplt1.Text = ""
lblPartTotalStdMins.Caption = "0"
Me.lblTotalPartsComp.Caption = "0"

Worksheets("DATATEMP").Range("A3:T137").ClearContents


ReloadDateTime
'RefreshListbox
Call List_box_Data

End Sub
'*''*'''''''''''''''''''''''''''''''''*''*'
'*''*' ^^^^^END BUTTON CONTROLS ^^^^^'*''*'
'*''*'''''''''''''''''''''''''''''''''*''*'

Private Sub ReloadDateTime()
Me.tbDate.Value = Format(Now(), "mm/dd/yyyy hh:mm")
End Sub

Sub List_box_Data()

Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("DATASUPPORT")

sh.Cells.ClearContents

Dim cnn As New ADODB.Connection
Dim rst As New ADODB.Recordset

Dim qry As String, i As Integer
Dim n As Long


qry = "SELECT * FROM TEST ORDER BY ID DESC"

'ElseIf Me.ComboBox1.Value = "Return Pending" Then
 ' Else
  'qry = "SELECT * FROM TBL_Customer WHERE Return_Date IS NULL"
   ' qry = "SELECT * FROM TBL_Customer WHERE " & Me.ComboBox1.Value & " LIKE '%" & Me.TextBox1.Value & "%'"
'End If


cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=\\superform\production\_Working Folders\MASTER\DBbackend\ProductionTrimShop1.accdb"

rst.Open qry, cnn, adOpenKeyset, adLockOptimistic

sh.Range("A2").CopyFromRecordset rst

For i = 1 To rst.Fields.Count
    sh.Cells(1, i).Value = rst.Fields(i - 1).Name
Next i

rst.Close
cnn.Close


With Me.ListBox1
    '.List = Dtarr
    .ColumnCount = 20
    .ColumnHeads = True
    .ColumnWidths = "18,25,80,140,50,80,80,40,40,40,40,40,40,80,40,40,80,80,80,80"


n = sh.Range("A" & Application.Rows.Count).End(xlUp).Row

If n > 1 Then
 .RowSource = "DATASUPPORT!A2:T" & n
Else
 .RowSource = "DATASUPPORT!A2:T2"
End If

End With


End Sub

Private Sub cboLostTime1_Change()
SumLostTime = Val(tbLostTime1.Text)
lblTotalLostMins.Caption = SumLostTime
End Sub

Private Sub cboLostTime2_Change()
SumLostTime2 = Val(tbLostTime1.Text) + Val(tbLostTime2.Text)
lblTotalLostMins.Caption = SumLostTime2
End Sub

Private Sub cboShiftEnd1_Change()
With cboShiftEnd1
.Value = Format(.Value, "hh:mm AM/PM")
.Value = IIf(.Value = "12:25 AM", "06:00", cboShiftEnd1)
End With
End Sub

Private Sub cboShiftStart1_Change()
With cboShiftStart1
.Value = Format(.Value, "hh:mm AM/PM")
.Value = IIf(.Value = "12:25 AM", "06:00", cboShiftStart1)
End With
End Sub

Private Sub btnAdmin_Click()
Unload Me
Application.Visible = True
End Sub

It is in .accdb format. I haven’t tried it on a 32-bit computer yet either but that is good to know before I do. But could it still effect 64-bit computers? — Intelligent_Meathead
I can enter all required data, click the save button, cursor starts to spin and hangs for about 5 seconds and then the userform just closes. Excel and all closes (workbook is hidden entire time) verified by keeping task manager open and watching while this happens each time. I have not stepped through the code on any other computer other than mine. I will tomorrow though when at work and get the chance. Hard to when one of the operators are working at the station. — Intelligent_Meathead

Unknown Unknown · Accepted Answer · 2020-05-15T04:38:00

After updating the computers experiencing this issue to Microsoft 365 from Office 2016 the problem went away.

I’d still like to know what could be a work around/fix so if anyone happens to know more or would like to test I’m happy to provide the file.

Why does my vba userform crash when clicking save button?

1 Answers