Currently my code will track whether something is entered in an intersection area between the columns C:E and target row. So if I enter data into C2:E2 as long as all cells in that range have data, the worksheet change event will run.

The worksheet change event will capture the date, the name of the worksheet and a log of the entry. The issue is then if an area with more than one row is affected i.e C2:E6 it will capture the data as such on multiple rows depending on how many rows were affected. How do I adjust the code so when multiple rows are affected i.e C2:E6 it will capture multiple entries - 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

CodePudding user response：

A Worksheet Change Modification

• This will trigger the event if any of the cells are changed in columns C:E, the first row excluded. It will loop through all of the cells' row ranges from column C to column E. If all cells in a row range are not blank, it will create a log entry in the log worksheet only if the entry doesn't already exist. If all cells in a row range are blank, using the row 'address', it will try to find a log entry and delete its entire row.

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