填充特定单元格时返回行地址

Question

我有一些代码会在 C:C 列中的任何一个被填充时返回行地址。

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Range
    For Each c In Target.Cells
        If Not Intersect(c, Range("C:C")) Is Nothing Then
        Application.EnableEvents = False
            Range("A" & c.Row).Value = c.Address
        
        End If
    Next c
End Sub

我将如何添加到此代码中，以便仅在相邻的 C:D:E 单元格以任何顺序填充时才会出现？因此，如果在 C5 然后 D5 然后 E5 中添加一个值，它将返回 5:5 作为行地址，但只有在所有 3 个单元格都有值之后，如果只有 C5 和 D5 被填充，它不会触发。

Answer 1

工作表更改

• 将代码复制到相应的工作表模块，例如Sheet1（括号内是标签名称）。

Option Explicit

' When done studying, out-comment or delete all the 'Debug.Print' lines
' except the one in the error-handling routine.

Private Sub Worksheet_Change(ByVal Target As Range)
    ' Use an error-handling routine to prevent exiting without enabling
    ' events in case of an error.
    On Error GoTo ClearError
    
    Const fRow As Long = 2
    Const cCols As String = "C:E"
    Const dCol As String = "A"
     
    Dim crg As Range
    Set crg = Columns(cCols).Resize(Rows.Count - fRow + 1).Offset(fRow - 1)
    Debug.Print "crg: " & crg.Address(0, 0)
    Dim irg As Range: Set irg = Intersect(crg, Target)
    
    If irg Is Nothing Then Exit Sub
    Debug.Print "irg: " & irg.Address(0, 0)
    
    Dim srg As Range: Set srg = Intersect(irg.EntireRow, crg)
    Debug.Print "srg: " & srg.Address(0, 0)
    
    ' I'm guessing that this is a too short operation since using
    ' the following line makes it kind of slow.
    'Application.ScreenUpdating = False
    ' Disable all events when writing to prevent retriggering the code.
    Application.EnableEvents = False
    
    Dim arg As Range ' Area Range
    Dim rrg As Range ' Area Row Range
    Dim RowString As String ' Current Row
    
    For Each arg In srg.Areas
        Debug.Print "arg: " & arg.Address(0, 0)
        For Each rrg In arg.Rows
            ' If the cell contains a fromula evaluating to ="",
            ' 'CountA' will count it. 'CountBlank' will consider it blank.
            If Application.CountBlank(rrg) = 0 Then
                RowString = CStr(rrg.Row)
                RowString = "'" & RowString & ":" & RowString
                rrg.EntireRow.Columns(dCol).Value = RowString
                Debug.Print "rrg: " & rrg.Address(0, 0) & " - " & RowString
            End If
        Next rrg
    Next arg

SafeExit:
     
    If Not Application.EnableEvents Then
        Application.EnableEvents = True ' enable all events when done writing
        'Application.ScreenUpdating = True ' too short operation
    End If
    
    Exit Sub ' don't forget this

ClearError:
    Debug.Print "Run-time error '" & Err.Number & "':" & Err.Description
    Resume SafeExit
End Sub


' Run this in VBE and see the results in the Immediate window ('Ctrl+G')
' Note that this is writing to a non-contiguous range (multi-range) which
' you can manually only copy, but it will be pasted contiguously.
' For this to work, 'Areas (arg)' is used as an additional complication.
Sub TestMultiRange()
    Dim rg As Range: Set rg = Range("C2:E4,C6:E6,C8:E10")
    rg.Value = "Test"

' Result in the Immediate window if all three-cell ranges are not blank:
'crg: C2:C1048576
'irg: C2:C4,C6,C8:C10
'brg: C:E
'srg: C2:E4,C6:E6,C8:E10
'arg: C2:E4
'rrg: C2:E2 - '2:2
'rrg: C3:E3 - '3:3
'rrg: C4:E4 - '4:4
'arg: C6:E6
'rrg: C6:E6 - '6:6
'arg: C8:E10
'rrg: C8:E8 - '8:8
'rrg: C9:E9 - '9:9
'rrg: C10:E10 - '10:10
End Sub