为什么单击保存按钮时我的 vba 用户窗体会崩溃？答案

【问题标题】：Why does my vba userform crash when clicking save button?为什么单击保存按钮时我的 vba 用户窗体会崩溃？
【发布时间】：2020-08-30 06:45:17
【问题描述】：

我在 excel 中创建了一个 vba 用户表单，用作前端用户数据收集界面。用户表单读取/写入我存储在本地网络上的访问数据库。

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

打开工作簿时，用户窗体加载正常，他们输入数据，然后单击保存。当他们单击保存时，表单会挂起几秒钟，然后就关闭了。之后没有其他事情发生。

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

我绝对不是 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

【问题讨论】：

它是 .accdb 格式。我还没有在 32 位计算机上尝试过，但在我做之前知道这一点很高兴。但它仍然会影响 64 位计算机吗？
到目前为止我试过的所有这些，是的。
我可以输入所有需要的数据，点击保存按钮，光标开始旋转并挂起大约 5 秒钟，然后用户窗体就关闭了。 Excel 和所有关闭（工作簿一直隐藏）通过保持任务管理器打开并在每次发生这种情况时进行观察来验证。除了我的以外，我没有在任何其他计算机上单步执行代码。我明天会在工作的时候得到机会。当一名操作员在车站工作时，这很难。
这里仍然没有变化，有人愿意试一试吗？

标签： excel vba ms-access userform

【解决方案1】：

在将遇到此问题的计算机从 Office 2016 更新到 Microsoft 365 后，问题就消失了。

我仍然想知道什么可以解决/修复，所以如果有人碰巧知道更多或想测试我很乐意提供文件。

【讨论】：