Блог

У меня есть код, который вернет адрес строки при заполнении любого столбца 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" amp; c.Row).Value = c.Address    End If  Next c End Sub   

Как бы я мог добавить в этот код, чтобы это происходило только тогда, когда соседние ячейки C:D:E заполняются в любом порядке? Поэтому, если бы значение было добавлено в C5, затем D5, а затем E5, оно вернуло бы 5:5 в качестве адреса строки, но только после того, как все 3 из этих ячеек будут иметь значения, если бы были заполнены только C5 и D5, оно не сработало бы.

Изменение Рабочего Листа

• Скопируйте код в соответствующий модуль листа, например 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: " amp; crg.Address(0, 0)  Dim irg As Range: Set irg = Intersect(crg, Target)    If irg Is Nothing Then Exit Sub  Debug.Print "irg: " amp; irg.Address(0, 0)    Dim srg As Range: Set srg = Intersect(irg.EntireRow, crg)  Debug.Print "srg: " amp; 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: " amp; 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 = "'" amp; RowString amp; ":" amp; RowString  rrg.EntireRow.Columns(dCol).Value = RowString  Debug.Print "rrg: " amp; rrg.Address(0, 0) amp; " - " amp; 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 '" amp; Err.Number amp; "':" amp; 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