如何循环遍历每个交叉路口而不是交叉路口区域？

Question

目前，我的代码将跟踪是否在列 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

Answer 1

工作表变更修改

如果第 C:E 列中的任何单元格发生更改，这将触发事件，第一行除外。它将遍历从 C 列到 E 列的所有单元格行范围。如果行范围内的所有单元格都不为空，则仅当该条目尚不存在时，它才会在日志工作表中创建一个日志条目。如果行范围内的所有单元格都是空白，使用行 'address'，它将尝试查找日志条目并删除其整行。

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

如何循环遍历每个交叉路口而不是交叉路口区域？

How do I loop through each intersection instead of intersection area?

excel

vba

intersection

工作表变更修改