我希望有人能幫我壓縮或簡化這個 Vba 代碼。
我想包含 AJ 列，而不必為每列復制代碼。
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
uj5u.com熱心網友回復：
作業表更改
您需要考慮此事件的兩個重要特征：
- 您需要通過設定
Application.EnableEvents為來防止在寫入單元格時重新觸發它，False但不要忘記True在寫入完成后將其設定為。 - 如果發生錯誤，
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
uj5u.com熱心網友回復：
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
轉載請註明出處，本文鏈接：https://www.uj5u.com/ruanti/374122.html