[英]Excel VBA - Date Cells automatically change back to Regional Date Format
I need to do validation in the active sheet. 我需要在活动工作表中进行验证。
The columns - Q, AA, AI, AS, BH and BI should be in Date format mm/dd/yyyy. 列-Q,AA,AI,AS,BH和BI的日期格式应为mm / dd / yyyy。
If those are not in mm/dd/yyyy format; 如果这些格式不是mm / dd / yyyy; then the cells are to be colored in Red Background and those entries to be sent to "Observations" Sheet in the same Excel Workbook as hyperlinks.
那么这些单元格将被着色为红色背景,并且这些条目将作为超链接发送到同一Excel工作簿中的“观察”表。
(Apart from it I have few other requirements.) (除此之外,我还有其他一些要求。)
For all those I have the following code. 对于所有这些,我都有以下代码。
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
The above codes work fine and colors cells whichever have entries such as dd-mm-yyyy OR dd/mm/yyyy OR mm-dd-yyyy in Red Background and sends those entries to "Observations" sheet as hyperlinks. 上面的代码可以正常工作,并且可以对红色背景中具有dd-mm-yyyy或dd / mm / yyyy或mm-dd-yyyy等条目的单元格进行着色 ,并将这些条目作为超链接发送到“观察”表。
But problem is when I try to correct such erroneous entries to correct format - " mm/dd/yyyy " and re-run my vba code; 但是问题是当我尝试更正此类错误条目以更正格式-“ mm / dd / yyyy ”并重新运行我的vba代码时; I find that those cells are not corrected and are back in the original erroneous format.
我发现这些单元格未得到纠正,并以原始错误格式返回。
ie Am not able to edit the erroneous cells, though I don't have any code to protect the cells from editing . 即我无法编辑错误的单元格,尽管我没有任何代码可以防止单元格被编辑 。
Can anyone tell where I am wrong - Or any improvements in the above code? 谁能说出我错了-或上述代码有任何改进吗?
This happened due to 'Regional formatting problem' 发生这种情况是由于“区域格式问题”
I changed number format of dates from 'date' format category to 'text' and now am able to correct the erroneous date cells. 我将日期的数字格式从“日期”格式类别更改为“文本”,现在能够更正错误的日期单元格。
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.