0

これに気付いたのはつい最近です。私は、ユーザーが 3 つの日付の情報を入力する傾向があるアプリケーションを持っています。開始日、終了日、および廃棄日。これらの日付ボックスの 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/mm/yyyy")
    dDate = txtEDate.Value = ""
End Sub

今気付いた問題は、これらの日付をコミットするときに、2012 年 1 月 3 日または 2012 年 5 月 6 日の日付を選択すると、シート上でそれぞれ 2012 年 3 月 1 日および 6 月 5 日に変更されることです。日付入力が 2012 年 6 月 13 日である場合、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. 私の質問は、フォームのように設定した形式に固執し、コミットしたら変更しないようにするにはどうすればよいですか?

前もって感謝します

4

1 に答える 1

0 
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 からの入力から修正された回答

于 2012-07-18T07:14:12.047 に答える