Multiple change value event not triggering in VBA (ByVal Target As Range)

user_13769734 0
Viewed 29

I have been trying to format cells in different rows one with number and another with date using VBA . My code is as below. But the second event is not getting triggered. When I interchange the 1s and 2nd event up to down (date first and number second), date format works and number doesn't works. Can I get any help here please?


*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*
vba excel
1 Answers

A Worksheet Change: Formats and Values in Multiple Columns

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
user_98140690
Related