Цикл по ячейкам, чтобы определить, выбран ли список проверки данных

Question

У меня есть макрос, который меняет цвет ячейки (смещение (0,1)), если ячейка слева говорит о доставке, а ячейка смещения пуста. Макрос вызывается изменением в списке проверки данных. Смотри ниже. Тем не менее, код не делает, как я хочу. Он не запускается каждый раз при сортировке списка проверки данных. Я хочу, чтобы это выполнялось каждый раз, когда параметр проверки данных изменяется в столбце W. (Список проверки применяется ко всем ячейкам в столбце W).

Код работает, но работает так, как я запускаю макрос на листеменять.

Сам макрос

Sub ConditionalFormatSharepointDeliveryLink()

Dim Lastrow As Long, n As Long, cell As Range, ws As Worksheet
Lastrow = Sheets("Sub Tasks").Range("W" & Rows.Count).End(xlUp).Row

n = 4

    For Each cell In Worksheets("Sub Tasks").Range("W4:W" & Lastrow)
        If cell.value = "Delivered" And cell.Offset(0, 1).value = "" Then
            cell.Offset(0, 1).Interior.Color = vbRed
        End If
    n = n + 1
    Next cell

End Sub

Как я вызываю макрос

Private Sub Worksheet_Change(ByVal Target As Range)


Dim Lastrow As Long, n As Long, cell As Range, ws As Worksheet
Lastrow = Sheets("Sub Tasks").Range("W" & Rows.Count).End(xlUp).Row

For Each cell In Worksheets("Sub Tasks").Range("W4:4" & Lastrow)
    If Target.Address(True, True) = cell Then
        Select Case Target
            Case "Delivered"
                Call ConditionalFormatSharepointDeliveryLink
        End Select
    End If

End Sub
``````````````````````````` 




[![enter image description here][1]][1]


  [1]: https://i.stack.imgur.com/BJzZB.png

Answer 1

Я не вижу необходимости во втором подпрограмме (но оставил его на тот случай, если вы хотите сохранить его для других целей, хотя вам следует добавить аргумент диапазона).

Проверьте пересечение между Target и столбец W, а затем запускать код только в том случае, если что-то есть (этого достаточно в Интернете).

Private Sub Worksheet_Change(ByVal Target As Range)

Dim Lastrow As Long, cell As Range
Lastrow = Sheets("Sub Tasks").Range("W" & Rows.Count).End(xlUp).Row

If Not Intersect(Target, Range("W4:W" & Lastrow)) Is Nothing Then
    For Each cell In Intersect(Target, Range("W4:W" & Lastrow))
        If cell.Value = "Delivered" And cell.Offset(0, 1).Value = vbNullString Then
            cell.Offset(0, 1).Interior.Color = vbRed
            'ConditionalFormatSharepointDeliveryLink
        End If
    Next cell
End If

End Sub

---

Обратите внимание, что все это можно сделать с помощью условного форматирования.

Answer 2

Это можно сделать полностью без цикла, например:

Private Sub Worksheet_Change(ByVal Target As Range)
lastrow = Sheets("Sub Tasks").Range("W" & Rows.Count).End(xlUp).Row
If Target.Value = "Delivered" Then
    If Application.Intersect(Target, Range("W4:W" & lastrow)) Is Nothing Then     Exit Sub
    Call ConditionalFormatSharepointDeliveryLink
End If
End Sub

В соответствии с вашими комментариями к другому ответу, вы можете вместо этого заменить эту подпункт на Worksheet_Change. Это будет работать, когда ячейка будет изменена на «Доставлено», но вышеприведенное работает только тогда, когда новая ячейка выбрана с «Доставлено» в имени.