为什么单击保存按钮时我的vba用户表单崩溃？

Question

我有一个在excel中创建的vba用户表单，我正在将其用作前端用户数据收集界面。该用户窗体读取/写入我已存储在本地网络中的访问数据库。

用户（多个工作站）正在运行Office 2010和Office2016。到目前为止，除了我自己的计算机以外，我还没有在其他任何计算机上使用此工具。

打开工作簿时，用户窗体可以很好地加载，他们输入数据，然后单击保存。当他们单击“保存”时，表格将挂起几秒钟，然后关闭。之后什么也没有发生。

我知道在这里使用访问表是更好的选择，但是很遗憾，我的公司规模不大，只为我自己购买了许可证。

我绝对不是vba的专家，并且我确定我的代码草率，所以任何建设性的反馈都将受到赞赏。

下面是我的用户表单代码：

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 (joshua.hart@luxfer.com,Quinn.Carney@Luxfer.com)
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 = "joshua.hart@luxfer.com;Quinn.Carney@Luxfer.com"
        .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