Question

我只是注意到这一点，我有一个应用程序，用户倾向于填写三个日期的信息。开始日期，结束日期和下降死亡日期。下面列出了其中一个日期框的示例

Private Sub txtEDate_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)

     'Dim dDate As Date
    dDate = DateSerial(Year(Date), Month(Date), Day(Date))
    txtEDate.Value = Format(txtEDate.Value, "dd/mm/yyyy")
    dDate = txtEDate.Value = ""
End Sub

我现在注意到的问题是当我选择日期时说2012年1月3日或5/6/2012，当我提交这些日期时，它们会在我的工作表上分别改为3/1/2012和6/5。如果我的日期输入是13/6/2012，它将保持不在12个月范围内。 excel表的格式与我设置的格式相同。也许这是我提交日期的问题。

Private Sub cmdOK_Click()
Dim checks As Integer

trim.trimALL
Call Check_Correct_Data_Entry_Total(checks)

If checks = 1 Then
    frmCourseBooking.Error_Messages.Caption = "ERROR: Please enter a Name..."
    Me.txtName.SetFocus
End If

If checks = 2 Then
    frmCourseBooking.Error_Messages.Caption = "ERROR: Please enter a Number..."
    Me.txtPhone.SetFocus
End If
If checks = 3 Then
    frmCourseBooking.Error_Messages.Caption = "ERROR: Please enter a ID..."
    Me.txtID.SetFocus
End If
If checks = 4 Then
    frmCourseBooking.Error_Messages.Caption = "ERROR: Please enter a Department.."
    Me.txtDepartment.SetFocus
End If
If checks = 5 Then
    frmCourseBooking.Error_Messages.Caption = "ERROR: Please enter a End Date.. "
    Me.txtEDate.SetFocus
End If
If checks = 6 Then
    frmCourseBooking.Error_Messages.Caption = "ERROR: Please enter a Analysis Dead Date.. "
    Me.txtDeadDate.SetFocus
End If
If checks = 7 Then
    frmCourseBooking.Error_Messages.Caption = "ERROR: Please enter a Analysis..."
    Me.cboAnalysis.SetFocus
End If
If checks = 8 Then
    frmCourseBooking.Error_Messages.Caption = "ERROR: Please enter a Application..."
    Me.cboApplication.SetFocus
End If
If checks = 9 Then
    frmCourseBooking.Error_Messages.Caption = "ERROR: Please enter amount of Disk Space you will be using..."
    Me.txtDisks.SetFocus
End If

If checks = 10 Then
    frmCourseBooking.Error_Messages.Caption = "ERROR: Please enter a Cluster..."
    Me.cboCluster.SetFocus
End If
If checks = 11 Then
    frmCourseBooking.Error_Messages.Caption = "ERROR: Please enter a Core Amount..."
    Me.cboCores.SetFocus
End If

If checks = 0 Then

    ActiveWorkbook.Sheets("Course Bookings").Activate

    Dim Row_to_Record_Data As Long

    Row_to_Record_Data = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1

    'Generate Unique Key for each new entry (Key = string of userid + numeric timestamp + random 3 letter string)

    Dim DateNumber As Long
    Dim RandomString1 As String
    Dim RandomString2 As String
    Dim RandomString3 As String
    Dim RandomString As String

    Dim Unique_Key As String

    DateNumber = Date
    RandomString1 = Chr(Application.WorksheetFunction.RandBetween(65, 90))
    RandomString2 = Chr(Application.WorksheetFunction.RandBetween(65, 90))
    RandomString3 = Chr(Application.WorksheetFunction.RandBetween(65, 90))
    RandomString = RandomString1 & RandomString2 & RandomString3
    Unique_Key = Format(Hour(Now), "00") & Format(Minute(Now), "00") & Format(Second(Now), "00") & RandomString

    'Check if overwriting entry selected from frmList ListBox
    If Overwrite_Row <> 0 Then Row_to_Record_Data = Overwrite_Row

    Cells(Row_to_Record_Data, 1).Value = txtName.Value
    Cells(Row_to_Record_Data, 2) = txtPhone.Value
    Cells(Row_to_Record_Data, 3) = LCase(txtID.Value)
    Cells(Row_to_Record_Data, 4) = txtDepartment.Value

    Cells(Row_to_Record_Data, 5) = cboAnalysis.Value
    Cells(Row_to_Record_Data, 6) = cboApplication.Value

   'ActiveCell.Offset(0, 7) = cboPriority.Value saved for priority to fill in off administration form

    Cells(Row_to_Record_Data, 9) = txtSDate.Value
    Cells(Row_to_Record_Data, 10) = txtDeadDate.Value
    'ADD ESTIMATED DATE HERE!!!!.
    Cells(Row_to_Record_Data, 11) = txtEDate.Value
    Cells(Row_to_Record_Data, 12) = cboCluster.Value
    Cells(Row_to_Record_Data, 13) = cboCores.Value
    Cells(Row_to_Record_Data, 14) = txtDisks.Value
    Cells(Row_to_Record_Data, 16) = txt_sge_number.Value


    'DVM CHOICES option.
    If optDefinition = True Then
        Cells(Row_to_Record_Data, 7).Value = "Definition"
    ElseIf optValidation = True Then
        Cells(Row_to_Record_Data, 7).Value = "Validation"
    Else
        Cells(Row_to_Record_Data, 7).Value = "Methods"
    End If

    'Enter Unique Key if new entry
    If Overwrite_Row = 0 Then Cells(Row_to_Record_Data, 15).Value = Unique_Key

End If

'frmCourseBooking.Error_Messages.Caption =

    Range("A1").Select

'clear form to avoid mishaps
If Overwrite_Row = 0 Then
    Accecptance_label.Caption = "Adding New Request, Recommend Clear Form After."
Else
    Accecptance_label.Caption = "Editted Request, Recommend Clear Form After."
End If

If checks = 0 Then
    Error_Messages.Caption = ""
End If

'Reset Overwrite_Row to zero
Overwrite_Row = 0


End Sub

这是我将这些日期提交给我的表格的全部功能。特别是它是Cells（Row_to_Record_Data，1）.Value = txtName.Value。我的问题是如何才能让它坚持我在表单中设置的格式，并且一旦提交就不会改变？

提前致谢

Answer 1

Private Sub txtEDate_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)       
'Dim dDate As Date    
 dDate = DateSerial(Year(Date), Month(Date), Day(Date))     
txtEDate.Value = Format(txtEDate.Value, "dd mmm yyyy")     
dDate = txtEDate.Value = "" 
End Sub

根据@Tony Dallimore的输入修改了答案

excel vba日期问题

1 个答案: