Excel VBA - 日期單元格自動更改回區域日期格式

Question

我需要在活動工作表中進行驗證。

列 - Q，AA，AI，AS，BH和BI應採用日期格式mm/dd/yyyy。

如果那些不是以mm/dd/yyyy格式;然後單元格將在紅色背景中着色，並將這些條目發送到與「超鏈接」相同的Excel工作簿中的「觀察」表單。

（除了它，我有一些其他的要求。）

對於所有那些我有下面的代碼。

Dim celArray, arr, Key1, KeyCell, celadr, celval, cell6 As Variant 


    celArray = ("Q,AA,AI,AS,BI,BH") 
    arr = Split(celArray, ",") 
    For Key1 = LBound(arr) To UBound(arr) 
    KeyCell = arr(Key1) 
    Range(KeyCell & "2:" & KeyCell & "" & LastRow).Select 

    ''Selection.Clearformats 
' Selection.TextToColumns Destination:=Range(KeyCell & "2"), DataType:=xlDelimited, _ 
'  TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _ 
'  Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _ 
'  :=Array(1, 3), TrailingMinusNumbers:=True 
' Columns(KeyCell & ":" & KeyCell).NumberFormat = "mm/dd/yyyy" 


    For Each cell6 In Selection 
     celadr = cell6.Address 
     celval = cell6.Value ' 
     If Len(celval) > 1 Then 

    Dim fistby As Integer 
    Dim secby As Integer 
    Dim tmpdte As Integer 
    Dim tmpyr As Integer 
    Dim tmpmth As Integer 

    '  If KeyCell = "Q" Then 
    '  Debug.Print celadr 
    '  End If 


     If IsDate(celval) Then 
      If KeyCell <> "BI" And KeyCell <> "BH" Then 
       If Range(celadr).Offset(0, 1).Value <> "" Or Range(celadr).Offset(0, 2).Value <> "" Or _ 
       Range(celadr).Offset(0, 3).Value <> "" Or Range(celadr).Offset(0, 4).Value <> "" Or _ 
       Range(celadr).Offset(0, 5).Value <> "" Or Range(celadr).Offset(0, 6).Value <> "" Or _ 
       Range(celadr).Offset(0, 7).Value <> "" Then 
        Range(celadr & ":" & Range(celadr).Offset(0, 7).Address).Interior.Color = vbRed 
        shname = ActiveSheet.Name 
        Sheets("Observations").Range("A65536").End(xlUp).Offset(1, 0).Value = celval 
        strstr = "'" & shname & "'!" & Range(celadr).Address(0, 0) 
        Sheets("Observations").Hyperlinks.Add Anchor:=Sheets("Observations").Range("A65536").End(xlUp), Address:="", SubAddress:= _ 
        strstr 
       End If 
      End If 
     End If 

     fistby = InStr(celval, "/") 
     secby = InStr(fistby + 1, celval, "/") 

    If fistby <> 0 Then 
     tmpdte = Mid(celval, fistby + 1, ((secby - 1) - fistby)) 
     tmpmth = Left(celval, fistby - 1) 
     'tmpyr = Right(celval, 4) 
    End If 

    If KeyCell = "Q" Then 
     If fistby = 0 Or tmpmth > 12 Or tmpdte > 31 Then 
      Range(celadr).Interior.Color = vbRed 
      shname = ActiveSheet.Name 
      Sheets("Observations").Range("A65536").End(xlUp).Offset(1, 0).Value = celval 
      strstr = "'" & shname & "'!" & Range(celadr).Address(0, 0) 
      Sheets("Observations").Hyperlinks.Add Anchor:=Sheets("Observations").Range("A65536").End(xlUp), Address:="", SubAddress:= _ 
      strstr 
     Else 
     If (Len(celval) <> 7 + fistby Or Mid(celval, fistby, 1) <> "/" Or Mid(celval, secby, 1) <> "/") Or Range(celadr).Offset(0, 8).Value <> "" Then 
      Range(celadr).Interior.Color = vbRed 
      shname = ActiveSheet.Name 
      Sheets("Observations").Range("A65536").End(xlUp).Offset(1, 0).Value = celval 
      strstr = "'" & shname & "'!" & Range(celadr).Address(0, 0) 
      Sheets("Observations").Hyperlinks.Add Anchor:=Sheets("Observations").Range("A65536").End(xlUp), Address:="", SubAddress:= _ 
      strstr 
     End If 
    End If 
    Else 
    If fistby = 0 Or tmpmth > 12 Or tmpdte > 31 Then 
     Range(celadr).Interior.Color = vbRed 
     shname = ActiveSheet.Name 
     Sheets("Observations").Range("A65536").End(xlUp).Offset(1, 0).Value = celval 
     strstr = "'" & shname & "'!" & Range(celadr).Address(0, 0) 
     Sheets("Observations").Hyperlinks.Add Anchor:=Sheets("Observations").Range("A65536").End(xlUp), Address:="", SubAddress:= _ 
     strstr 
    Else 
    If (Len(celval) <> 7 + fistby Or Mid(celval, fistby, 1) <> "/" Or Mid(celval, secby, 1) <> "/") Then 
     Range(celadr).Interior.Color = vbRed 
     shname = ActiveSheet.Name 
     Sheets("Observations").Range("A65536").End(xlUp).Offset(1, 0).Value = celval 
     strstr = "'" & shname & "'!" & Range(celadr).Address(0, 0) 

     Dim adrr As Variant 
     adrr = Sheets("Observations").Range("A65536").End(xlUp).Address 
     End If 
     End If 
     End If 
     End If 
    Next cell6 
    'Columns(KeyCell & ":" & KeyCell).NumberFormat = "mm/dd/yyyy" 
    Next Key1 

上述代碼很好地工作和顏色細胞取其具有條目，如DD-MM-yyyy或DD/MM/yyyy或MM-DD-YYYY在紅色背景併發送那些條目到「觀察」表格作爲超鏈接。

但問題是，當我嘗試糾正這種錯誤的條目，以正確的格式 - 「mm/dd/yyyy」並重新運行我的vba代碼;我發現那些單元格沒有被糾正，並且回到原來的錯誤格式。

即雖然我沒有任何代碼來保護單元格以免編輯，但我無法編輯錯誤的單元格。

任何人都可以告訴我哪裏錯了嗎？或者上述代碼有任何改進？

Answer 1

這發生由於「區域格式問題」

我改日期的數字格式從「日期」格式類別「文本」現在我能改正錯誤的日期細胞。