时间戳vba简化

Question

我希望有人能帮我压缩或简化这个Vba代码。

我希望包含A-J列，而不必为每列重复代码。

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

Answer 1

工作表更改

• 您需要考虑此事件的两个重要特征：

  1. 在向单元格写入时，需要通过将Application.EnableEvents设置为False来防止重新触发它，但不要忘记在写入完成后将其设置为True
  2. 如果发生错误，Application.EnableEvents可能保持为False，这将阻止任何事件触发。因此，使用错误处理例程，您需要确保在退出过程之前将其设置为True

• 此示例仅限于一个单元格。如果复制粘贴多个单元格，则不会进行任何更改。

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

Answer 2

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