目前，我的代碼將跟蹤是否在列 C:E 和目標行之間的交叉區域中輸入了某些內容。因此，如果我在 C2:E2 中輸入資料，只要該范圍內的所有單元格都有資料，作業表更改事件就會運行。
作業表更改事件將捕獲日期、作業表名稱和條目日志。問題是，如果超過一行的區域受到影響，即 C2:E6，它將根據受影響的行數在多行上捕獲這樣的資料。如何調整代碼，以便當多行受到影響時，即 C2:E6，它將捕獲多個條目 - C2:E2 - C3:E3 - C4:E4 - C5:E5 - C6-E6。
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const fRow As Long = 2
Const cCols As String = "C:E"
Dim SheetName As String
Dim lngth As Range
Dim LogSearchRange As Range, R As Range
Dim Findstr As Range
Dim crg As Range
Set crg = Columns(cCols).Resize(Rows.Count - fRow 1).Offset(fRow - 1)
Dim irg As Range: Set irg = Intersect(crg, Target)
SheetName = ActiveSheet.Name
If irg Is Nothing Then Exit Sub
Dim srg As Range: Set srg = Intersect(irg.EntireRow, crg)
Debug.Print srg.Address(0, 0)
Application.EnableEvents = False
Dim arg As Range
Dim rrg As Range
Dim RowString As String
Dim AreaString As String
AreaString = srg.Address(False, False)
RowString = SheetName & "!" & AreaString
With Sheets("Log")
Set LogSearchRange = Application.Intersect(.UsedRange, .Columns(3))
Set Findstr = LogSearchRange.Find(What:=RowString, LookAt:=xlWhole)
For Each arg In srg.Areas
For Each rrg In arg.Rows
If Application.CountBlank(rrg) = 0 And Findstr Is Nothing Then
With Sheets("Log")
.Cells(1, 1).End(xlDown).Offset(1).Value = Format(Date, "dd/mm/yyyy")
.Cells(1, 2).End(xlDown).Offset(1).Value = ActiveSheet.Name
.Cells(1, 2).End(xlDown).Offset(0, 1) = RowString
End With
Else
If Application.CountBlank(srg) = 3 Then
With Worksheets("Log")
Set LogSearchRange = Application.Intersect(.UsedRange, .Columns(3))
Set R = LogSearchRange.Find(What:=RowString, LookAt:=xlWhole)
If Not R Is Nothing Then
R.EntireRow.Delete Shift:=xlUp
End If
End With
End If
End If
Next rrg
Next arg
End With
SafeExit:
If Not Application.EnableEvents Then
Application.EnableEvents = True
End If
Exit Sub
End Sub
uj5u.com熱心網友回復：
作業表更改修改
- 如果列中的任何單元格發生更改，這將觸發事件
C:E，排除第一行。它將遍歷從 columnC到 column 的所有單元格的行范圍E。如果行范圍中的所有單元格都不為空，則僅當該條目不存在時，它才會在日志作業表中創建一個日志條目。如果行范圍中的所有單元格都為空，則使用行“地址”，它將嘗試查找日志條目并洗掉其整行。
Option Explicit
' Since you're not writing to the source worksheet (Me, ActiveSheet),
' you don't need to disable events.
Private Sub Worksheet_Change(ByVal Target As Range)
Const fRow As Long = 2
Const cCols As String = "C:E"
Const dName As String = "Log"
Const dCol As String = "A"
Const dcCol As String = "C"
Dim crg As Range
Set crg = Columns(cCols).Resize(Rows.Count - fRow 1).Offset(fRow - 1)
Dim irg As Range: Set irg = Intersect(crg, Target)
If irg Is Nothing Then Exit Sub
Dim srg As Range: Set srg = Intersect(irg.EntireRow, crg)
Dim sName As String: sName = Me.Name
Dim dws As Worksheet: Set dws = Me.Parent.Worksheets(dName)
Dim dfCell As Range: Dim ddcrg As Range: Set ddcrg = dws.Columns(dcCol)
Dim arg As Range
Dim rrg As Range
Dim srAddress As String
Dim ddFound As Range
For Each arg In srg.Areas
For Each rrg In arg.Rows
srAddress = sName & "!" & rrg.Address(0, 0)
Set ddFound = ddcrg.Find(srAddress, , xlFormulas, xlWhole)
If Application.CountBlank(rrg) = 0 Then ' no blanks
If ddFound Is Nothing Then ' not found in the log
Set dfCell = dws.Cells(dws.Rows.Count, dCol) _
.End(xlUp).Offset(1)
' While developing the code, it is always better to use ...
'dfCell.Value = Format(Now, "dd/mm/yyyy hh:mm:ss")
' ...since you don't want to wait for days for a change.
dfCell.Value = Format(Date, "dd/mm/yyyy")
dfCell.Offset(, 1).Value = Me.Name
dfCell.Offset(, 2).Value = srAddress
End If
ElseIf Application.CountBlank(srg) = 3 Then ' all blanks
If Not ddFound Is Nothing Then ' found in the log
ddFound.EntireRow.Delete Shift:=xlShiftUp
End If
'Else ' Neither no blanks, nor all blanks
End If
Next rrg
Next arg
End Sub
轉載請註明出處，本文鏈接：https://www.uj5u.com/qianduan/383981.html