VBA 中未触发多个更改值事件（ByVal Target As Range）

Question

我一直在尝试使用 VBA 格式化不同行中的单元格，一个带有数字，另一个带有日期。我的代码如下。但是第二个事件没有被触发。当我将 1s 和 2nd 事件上下互换时（日期第一和数字第二），日期格式有效，数字无效。请问我可以在这里得到任何帮助吗？

*Private Sub Worksheet_Change(ByVal Target As Range)
   
'___________ 8 DIGITS FORMAT ____________________
   
   
Dim i As Integer
Dim cell As Integer
Application.EnableEvents = False
On Error GoTo Err 'To avoid error when multiple cells are selected
    If Not Intersect(Target, Range("U:U")) Is Nothing Or _
       Not Intersect(Target, Range("B:B")) And Target.Value <> "" Then
cell = Target.Rows.Count
    
For i = 1 To cell
'To avoid cells with NO VALUE to be FORMATTED
If Target.Cells(i, 1).Value <> "" Then
Target.Cells(i, 1).NumberFormat = "@"
Target.Cells(i, 1).Value = Application.WorksheetFunction.Text(Target.Cells(i, 1).Value, "00000000")
Else
Resume LetsContinue
End If
Next i
End If
    
Application.EnableEvents = True
    
'______________________ Date Format ____________________
   
   
Dim x As Integer
Dim dt As Integer
Application.EnableEvents = False
On Error GoTo Err2 'To avoid error when multiple cells are selected
    If Not Intersect(Target, Range("E:E")) Is Nothing Or _
       Not Intersect(Target, Range("AQ:AQ")) And Target.Value <> "" Then
dt = Target.Rows.Count
    
    
For x = 1 To dt
'To avoid cells with NO VALUE to be FORMATTED
If Target.Cells(x, 1).Value <> "" Then
Target.Cells(x, 1).NumberFormat = "dd-Mmm-yyyy"
Target.Cells(x, 1).Value = Application.WorksheetFunction.Text(Target.Cells(x, 1).Value, "dd-Mmm-yyyy")
Else
Resume LetsContinue
End If
Next x
Else
End If
Application.EnableEvents = True
Err:
    If Not Intersect(Target, Range("U:U")) Is Nothing Or Not Intersect(Target, Range("B:B")) Is Nothing Then
    Resume Next
    Else
    Resume LetsContinue
    End If
Err2:
    If Not Intersect(Target, Range("E:E")) Is Nothing Or Not Intersect(Target, Range("AQ:AQ")) Is Nothing Then
    Resume Next
    Else
    Resume LetsContinue
    End If
    
 
LetsContinue:
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Exit Sub
    
    
Whoa:
    
    Resume LetsContinue
    
  
    End Sub*

Answer 1

工作表更改：多列中的格式和值

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim rg As Range
    Dim irg As Range
    
    ' 8 digits
    
    Set rg = RefColumns(Me, 2, "B,U")
    Set irg = Intersect(rg, Target)
    
    If Not irg Is Nothing Then
        Format8Digits irg
        Set irg = Nothing
    End If
    
    ' Dates
    
    Set rg = RefColumns(Me, 2, "E,AQ")
    Set irg = Intersect(rg, Target)

    If Not irg Is Nothing Then
        FormatDates irg
        Set irg = Nothing
    End If

End Sub


Function RefColumns( _
    ByVal ws As Worksheet, _
    ByVal FirstRow As Long, _
    ByVal ColumnsList As String, _
    Optional ByVal Delimiter As String = ",") _
As Range
    
    Dim Cols() As String: Cols = Split(ColumnsList, ",")
    Dim rResize As Long: rResize = ws.Rows.Count - FirstRow + 1
    
    Dim trg As Range
    Dim rg As Range
    Dim n As Long
    
    For n = 0 To UBound(Cols)
        Set rg = ws.Cells(FirstRow, Cols(n)).Resize(rResize)
        If trg Is Nothing Then Set trg = rg Else Set trg = Union(trg, rg)
    Next n
    
    Set RefColumns = trg

End Function

Sub Format8Digits(ByVal rg As Range)
    On Error GoTo ClearError
    
    Application.EnableEvents = False
    Dim Cell As Range
    For Each Cell In rg.Cells
        If Len(CStr(Cell.Value)) > 0 Then
            Cell.NumberFormat = "@"
            Cell.Value = Application.WorksheetFunction _
                .Text(Cell.Value, "00000000")
        End If
    Next Cell
    
SafeExit:
    Application.EnableEvents = True
    Exit Sub
ClearError:
    Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
    Resume SafeExit
End Sub

Sub FormatDates(ByVal rg As Range)
    On Error GoTo ClearError
    
    Application.EnableEvents = False
    Dim Cell As Range
    For Each Cell In rg.Cells
        If IsDate(Cell) Then
            Cell.NumberFormat = "dd-Mmm-yyyy"
            Cell.Value = Application.WorksheetFunction _
                .Text(Cell.Value, "dd-Mmm-yyyy")
        End If
    Next Cell
    
SafeExit:
    Application.EnableEvents = True
    Exit Sub
ClearError:
    Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
    Resume SafeExit
End Sub

Answer 2

我在 2 个月后找到了这个查询的解决方案。

在第一个事件中，当我们给出实际结束代码的 Resume LetsContinue 时，应该触发第二个事件，并且应该在第一个事件中定义名称和恢复“事件”来定义第二个和后续事件。

应该是这样的：

Resume Event2
End If
Next i
End If
    
Application.EnableEvents = True
    
'______________________ Date Format ____________________
   
Event2:
   
Dim x As Integer
Dim dt As Integer
Application.EnableEvents = False
On Error GoTo Err2 'To avoid error when multiple cells are selected
    If Not Intersect(Target, Range("E:E")) Is Nothing Or _
       Not Intersect(Target, Range("AQ:AQ")) And Target.Value <> "" Then
dt = Target.Rows.Count

代码继续----------------