I was hoping someone could help me compress or simplify this Vba code.
I want to include columns A-J without having to duplicate the code for each column.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A3:A9999")) Is Nothing Then
For Each cell In Target
If cell.Value = "" Then
cell.Offset(0, 10).ClearContents
cell.Offset(0, 11).ClearContents
Else
If cell.Offset(0, 10).Value = "" Then
cell.Offset(0, 10).Value = Now
End If
cell.Offset(0, 11).Value = Now
End If
Next cell
End If
If Not Intersect(Target, Range("B3:B9999")) Is Nothing Then
For Each cell In Target
If cell.Value = "" Then
cell.Offset(0, 9).ClearContents
cell.Offset(0, 10).ClearContents
Else
If cell.Offset(0, 9).Value = "" Then
cell.Offset(0, 9).Value = Now
End If
cell.Offset(0, 10).Value = Now
End If
Next cell
End If
If Not Intersect(Target, Range("C3:C9999")) Is Nothing Then
For Each cell In Target
If cell.Value = "" Then
cell.Offset(0, 8).ClearContents
cell.Offset(0, 9).ClearContents
Else
If cell.Offset(0, 8).Value = "" Then
cell.Offset(0, 8).Value = Now
End If
cell.Offset(0, 9).Value = Now
End If
Next cell
End If
If Not Intersect(Target, Range("D3:D9999")) Is Nothing Then
For Each cell In Target
If cell.Value = "" Then
cell.Offset(0, 7).ClearContents
cell.Offset(0, 7).ClearContents
Else
If cell.Offset(0, 7).Value = "" Then
cell.Offset(0, 7).Value = Now
End If
cell.Offset(0, 8).Value = Now
End If
Next cell
End If
If Not Intersect(Target, Range("E3:E9999")) Is Nothing Then
For Each cell In Target
If cell.Value = "" Then
cell.Offset(0, 6).ClearContents
cell.Offset(0, 6).ClearContents
Else
If cell.Offset(0, 6).Value = "" Then
cell.Offset(0, 6).Value = Now
End If
cell.Offset(0, 7).Value = Now
End If
Next cell
End If
If Not Intersect(Target, Range("F3:F9999")) Is Nothing Then
For Each cell In Target
If cell.Value = "" Then
cell.Offset(0, 5).ClearContents
cell.Offset(0, 5).ClearContents
Else
If cell.Offset(0, 5).Value = "" Then
cell.Offset(0, 5).Value = Now
End If
cell.Offset(0, 6).Value = Now
End If
Next cell
End If
If Not Intersect(Target, Range("G3:G9999")) Is Nothing Then
For Each cell In Target
If cell.Value = "" Then
cell.Offset(0, 4).ClearContents
cell.Offset(0, 4).ClearContents
Else
If cell.Offset(0, 4).Value = "" Then
cell.Offset(0, 4).Value = Now
End If
cell.Offset(0, 5).Value = Now
End If
Next cell
End If
If Not Intersect(Target, Range("H3:H9999")) Is Nothing Then
For Each cell In Target
If cell.Value = "" Then
cell.Offset(0, 3).ClearContents
cell.Offset(0, 3).ClearContents
Else
If cell.Offset(0, 3).Value = "" Then
cell.Offset(0, 3).Value = Now
End If
cell.Offset(0, 4).Value = Now
End If
Next cell
End If
If Not Intersect(Target, Range("I3:I9999")) Is Nothing Then
For Each cell In Target
If cell.Value = "" Then
cell.Offset(0, 2).ClearContents
cell.Offset(0, 2).ClearContents
Else
If cell.Offset(0, 2).Value = "" Then
cell.Offset(0, 2).Value = Now
End If
cell.Offset(0, 3).Value = Now
End If
Next cell
End If
If Not Intersect(Target, Range("J3:J9999")) Is Nothing Then
For Each cell In Target
If cell.Value = "" Then
cell.Offset(0, 1).ClearContents
cell.Offset(0, 1).ClearContents
Else
If cell.Offset(0, 1).Value = "" Then
cell.Offset(0, 1).Value = Now
End If
cell.Offset(0, 2).Value = Now
End If
Next cell
End If
End Sub
CodePudding user response：
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range, i As Long
If Intersect(Target, Range("A3:J9999")) Is Nothing Then
Exit Sub
Else
For Each cell In Intersect(Target, Range("A3:J9999"))
i = 11 - Target.Column
If cell.Value = "" Then
cell.Offset(0, i).ClearContents
cell.Offset(0, i 1).ClearContents
Else
If cell.Offset(0, i).Value = "" Then
cell.Offset(0, i).Value = Now
End If
cell.Offset(0, i 1).Value = Now
End If
Next
End If
End Sub
CodePudding user response：
A Worksheet Change
You need to consider two important characteristics of this event:
- You need to prevent re-triggering it when writing to cells by setting
Application.EnableEventstoFalsebut not to forget to set it toTrueafter writing has finished. - If an error occurs,
Application.EnableEventsmight remainFalse, which would prevent any event from triggering. Therefore, using an error-handling routine, you need to make sure it gets set toTruebefore exiting the procedure.
- You need to prevent re-triggering it when writing to cells by setting
This example is restricted to one cell only. If you copy-paste more than one cell, no changes will be made.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ClearError ' enable error handling
Const fRow As Long = 3
If Target.Cells.CountLarge > 1 Then Exit Sub ' restrict to one cell
Dim crg As Range
Dim iCell As Range
With Columns("A:J")
' 'A3:J1048576'
Set crg = .Resize(.Rows.Count - fRow 1).Offset(fRow - 1)
Set iCell = Intersect(crg, Target)
End With
If iCell Is Nothing Then Exit Sub
'Application.ScreenUpdating = False ' if many cells
Application.EnableEvents = False ' to not retrigger when writing
If IsEmpty(iCell) Then
iCell.EntireRow.Columns("K:L").ClearContents
Else
If IsEmpty(Cells(iCell.Row, "K")) Then
Cells(iCell.Row, "K").Value = Now
End If
Cells(iCell.Row, "L").Value = Now
End If
SafeExit:
If Not Application.EnableEvents Then ' re-enable events (even if error)
Application.EnableEvents = True
End If
'Application.ScreenUpdating = True ' if many cells
Exit Sub
ClearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume SafeExit
End Sub