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 OR mm-dd-yyyy 等条目，并将这些条目发送到“观察” “表格作为超链接。

但问题是当我尝试纠正这些错误的条目以纠正格式 - “ mm / dd / yyyy ”并重新运行我的vba代码时;我发现那些细胞没有得到纠正，并且恢复原来的错误格式。

即。 我无法编辑错误的单元格，但我没有任何代码可以保护单元格不被编辑。

任何人都可以告诉我错在哪里 - 或上述代码中的任何改进？

Answer 1

这是由于地区格式问题＆＃39;

造成的

我更改了日期＆＃39;日期的数字格式。格式类别为＆＃39; text＆＃39;现在能够纠正错误的日期单元格。

Excel VBA - 日期单元格自动更改回区域日期格式

1 个答案: