Как я могу сделать цикл для запуска этого кода 15 раз, используя список переменных диапазона, которые я определил?

Question

Я выполняю один и тот же код для каждого из 15 статических диапазонов в (текущем) событии Worksheet_Change. Каждый диапазон оценивается сам по себе.

Я проверяю дубликаты, но не по диапазонам, только в каждом отдельном диапазоне. Но все диапазоны должны быть проверены (или вплоть до действия) до завершения процедуры.

Ячейки заполняются по выбору пользователя из динамических раскрывающихся списков для всех ячеек.

Код, который я публикую, работает так, как мне нужно. Как сделать цикл для запуска одного и того же кода 15 раз, используя список переменных диапазона, которые я определил?

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

Я пробовал несколько версий исследуемого кода, чтобы сделать код зацикливания функциональным, но множественные операторы If затрудняют мне поиск правильной структуры для цикла.

Я, наконец, сдался и скопировал код 15 раз в операторе If - ElseIf, который работает.

Private Sub Worksheet_Change(ByVal Target As Range)

'Define your variables.
Dim Sun1AM As Range, Sun1PM As Range, Wed1PM As Range
Dim Sun2AM As Range, Sun2PM As Range, Wed2PM As Range
Dim Sun3AM As Range, Sun3PM As Range, Wed3PM As Range
Dim Sun4AM As Range, Sun4PM As Range, Wed4PM As Range
Dim Sun5AM As Range, Sun5PM As Range, Wed5PM As Range

'Set the ranges where you want to prevent duplicate entries.
Set Sun1AM = Range("C4:C14")
Set Sun1PM = Range("C17:C21")
Set Wed1PM = Range("C24:C28")
Set Sun2AM = Range("E4:E14")
Set Sun2PM = Range("E17:E21")
Set Wed2PM = Range("E24:E28")
Set Sun3AM = Range("G4:G14")
Set Sun3PM = Range("G17:G21")
Set Wed3PM = Range("G24:G28")
Set Sun4AM = Range("I4:I14")
Set Sun4PM = Range("I17:I21")
Set Wed4PM = Range("I24:I28")
Set Sun5AM = Range("K4:K14")
Set Sun5PM = Range("K17:K21")
Set Wed5PM = Range("K24:K28")


'See if target is in any of the ranges defined above and check for 
'duplicates range by range.
If Not Intersect(Target, Sun1AM) Is Nothing Then
    If Target.Cells.Count > 1 Then Exit Sub
        If WorksheetFunction.CountIf(Sun1AM, Target.Value) > 1 Then _
           MsgBox Target.Value & " is already used.", vbInformation, _ 
           "Duplicate Entry!"

ElseIf Not Intersect(Target, Sun1PM) Is Nothing Then
    If Target.Cells.Count > 1 Then Exit Sub
        If WorksheetFunction.CountIf(Sun1PM, Target.Value) > 1 Then _
           MsgBox Target.Value & " is already used.", vbInformation, _
           "Duplicate Entry!"

ElseIf Not Intersect(Target, Wed1PM) Is Nothing Then
    If Target.Cells.Count > 1 Then Exit Sub
        If WorksheetFunction.CountIf(Wed1PM, Target.Value) > 1 Then _
           MsgBox Target.Value & " is already used.", vbInformation, _
           "Duplicate Entry!"

ElseIf Not Intersect(Target, Sun2AM) Is Nothing Then
    If Target.Cells.Count > 1 Then Exit Sub
        If WorksheetFunction.CountIf(Sun2AM, Target.Value) > 1 Then _
           MsgBox Target.Value & " is already used.", vbInformation, _
           "Duplicate Entry!"

ElseIf Not Intersect(Target, Sun2PM) Is Nothing Then
    If Target.Cells.Count > 1 Then Exit Sub
        If WorksheetFunction.CountIf(Sun2PM, Target.Value) > 1 Then _
           MsgBox Target.Value & " is already used.", vbInformation, _
           "Duplicate Entry!"

ElseIf Not Intersect(Target, Wed2PM) Is Nothing Then
    If Target.Cells.Count > 1 Then Exit Sub
        If WorksheetFunction.CountIf(Wed2PM, Target.Value) > 1 Then _
           MsgBox Target.Value & " is already used.", vbInformation, _
           "Duplicate Entry!"

ElseIf Not Intersect(Target, Sun3AM) Is Nothing Then
    If Target.Cells.Count > 1 Then Exit Sub
        If WorksheetFunction.CountIf(Sun3AM, Target.Value) > 1 Then _
           MsgBox Target.Value & " is already used.", vbInformation, _
           "Duplicate Entry!"

ElseIf Not Intersect(Target, Sun3PM) Is Nothing Then
    If Target.Cells.Count > 1 Then Exit Sub
        If WorksheetFunction.CountIf(Sun3PM, Target.Value) > 1 Then _
           MsgBox Target.Value & " is already used.", vbInformation, _
           "Duplicate Entry!"

ElseIf Not Intersect(Target, Wed3PM) Is Nothing Then
    If Target.Cells.Count > 1 Then Exit Sub
        If WorksheetFunction.CountIf(Wed3PM, Target.Value) > 1 Then _
           MsgBox Target.Value & " is already used.", vbInformation, _
           "Duplicate Entry!"

ElseIf Not Intersect(Target, Sun4AM) Is Nothing Then
    If Target.Cells.Count > 1 Then Exit Sub
        If WorksheetFunction.CountIf(Sun4AM, Target.Value) > 1 Then _
           MsgBox Target.Value & " is already used.", vbInformation, _
           "Duplicate Entry!"

ElseIf Not Intersect(Target, Sun4PM) Is Nothing Then
    If Target.Cells.Count > 1 Then Exit Sub
        If WorksheetFunction.CountIf(Sun4PM, Target.Value) > 1 Then _
           MsgBox Target.Value & " is already used.", vbInformation, _
           "Duplicate Entry!"

ElseIf Not Intersect(Target, Wed4PM) Is Nothing Then
    If Target.Cells.Count > 1 Then Exit Sub
        If WorksheetFunction.CountIf(Wed4PM, Target.Value) > 1 Then _
           MsgBox Target.Value & " is already used.", vbInformation, _
           "Duplicate Entry!"

ElseIf Not Intersect(Target, Sun5AM) Is Nothing Then
    If Target.Cells.Count > 1 Then Exit Sub
        If WorksheetFunction.CountIf(Sun5AM, Target.Value) > 1 Then _
           MsgBox Target.Value & " is already used.", vbInformation, _
           "Duplicate Entry!"

ElseIf Not Intersect(Target, Sun5PM) Is Nothing Then
    If Target.Cells.Count > 1 Then Exit Sub
        If WorksheetFunction.CountIf(Sun5PM, Target.Value) > 1 Then _
           MsgBox Target.Value & " is already used.", vbInformation, _
           "Duplicate Entry!"

ElseIf Not Intersect(Target, Wed5PM) Is Nothing Then
    If Target.Cells.Count > 1 Then Exit Sub
        If WorksheetFunction.CountIf(Wed5PM, Target.Value) > 1 Then _
           MsgBox Target.Value & " is already used.", vbInformation, _
           "Duplicate Entry!"

Else
    Exit Sub

End If

End Sub

Это работает, но очень сложно управлять. Кто-нибудь, пожалуйста, просветите меня в хороший простой цикл. Я буду копировать этот лист, создавая новую копию каждый месяц, поэтому код должен оставаться «текущим листом» и работать с любым листом, над которым работает пользователь.

Большое спасибо !!!

Answer 1

Если шаблон диапазонов точно такой же, то можете попробовать

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
Dim SrcRng As Range, URng As Range
Dim Cl As Long, EndRw As Long, StartRw As Long, EndRwID As Long

    For Cl = 3 To 11 Step 2
        For EndRwID = 2 To 4
        EndRw = EndRwID * 7
        StartRw = IIf(EndRwID = 2, EndRw - 10, EndRw - 4)
        Set SrcRng = Range(Cells(StartRw, Cl), Cells(EndRw, Cl))

        'See if target is in any of the ranges defined above and check for
        'duplicates range by range.
            If Not Intersect(Target, SrcRng) Is Nothing Then
                If WorksheetFunction.CountIf(SrcRng, Target.Value) > 1 Then _
                MsgBox Target.Value & " is already used.", vbInformation, _
                "Duplicate Entry!"
            Exit For
            End If

    Next EndRwID
    Next Cl
End Sub

Или же, если диапазоны, требующие проверки d, не всегда соответствуют шаблону, тогда можно попробовать

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub

Dim SrcRng(1 To 15) As Range
Dim i As Long

Set SrcRng(1) = Range("C4:C14")
Set SrcRng(2) = Range("C17:C21")
Set SrcRng(3) = Range("C24:C28")
Set SrcRng(4) = Range("E4:E14")
Set SrcRng(5) = Range("E17:E21")
Set SrcRng(6) = Range("E24:E28")
Set SrcRng(7) = Range("G4:G14")
Set SrcRng(8) = Range("G17:G21")
Set SrcRng(9) = Range("G24:G28")
Set SrcRng(10) = Range("I4:I14")
Set SrcRng(11) = Range("I17:I21")
Set SrcRng(12) = Range("I24:I28")
Set SrcRng(13) = Range("K4:K14")
Set SrcRng(14) = Range("K17:K21")
Set SrcRng(15) = Range("K24:K28")


        For i = 1 To 15
        'See if target is in any of the ranges defined above and check for
        'duplicates range by range.
            If Not Intersect(Target, SrcRng(i)) Is Nothing Then
            If WorksheetFunction.CountIf(SrcRng(i), Target.Value) > 1 Then _
            MsgBox Target.Value & " is already used.", vbInformation, _
            "Duplicate Entry!"
            Exit For
            End If
      Next i
End Sub

Answer 2

Ответ любезно предоставлен Тимом Уильямсом (см. Пост выше) https://stackoverflow.com/users/478884/tim-williams

Примечание: этот код проверяет, вводит ли пользователь повторяющиеся значения в диапазоны C4: C14, C17: C21, C24: C28, E4: E14, E17: E21, E24: E28, G4: G14, G17: G21, G24: G28, I4: I14, I17: I21, I24: I28, K4: K14, K17: K21, K24: только C28.

Это статические диапазоны назначений в динамическом месячном календаре назначений. Этот код не удаляет и не предотвращает повторяющиеся записи. Он только сообщает пользователю с окном сообщения vbInformation, что человеку было назначено более одной задачи в данный день. Он уведомляет, что «кто-то» уже был использован, и пользователь может оставить или отредактировать дубликат. Этот лист (основная копия) копируется как новый пустой лист для каждого месяца, задания заполняются и распечатываются. Сам лист изменяется динамически, чтобы отображать правильные календарные даты раз в месяц и год. Этот код предназначен для работы с «активным» рабочим листом, поскольку одновременно назначается только один месяц (один лист), а прошедшие месяцы остаются справочными документами.

Private Sub Worksheet_Change(ByVal Target As Range)    'By Tim Williams

Dim rng As Range, a As Range

If Target.CountLarge > 1 Then Exit Sub 'only need this test once
If IsEmpty(Target) Then Exit Sub       'added check for empty target on delete action

Set rng = Range("C4:C14,C17:C21,C24:C28") 'start here
Do While rng.Column <= 11
    'loop over the areas in the range
    For Each a In rng.Areas
        If Not Intersect(Target, a) Is Nothing _
           And WorksheetFunction.CountIf(a, Target.Value) > 1 Then
            MsgBox Target.Value & " is already used", _
            vbInformation, "Duplicate Entry!"

            Exit Do
        End If    

    Next a
    Set rng = rng.Offset(0, 2) 'move two columns to the right
Loop

End Sub

Большое спасибо Тиму за то, что он показал мне, как упростить мой громоздкий код до невероятно аккуратной и простой процедуры.

Answer 3

Примерно так:

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim rng As Range, a As Range

    If Target.CountLarge > 1 Then Exit Sub 'only need this test once

    Set rng = Me.Range("C4:C14,C17:C21,C24:C28") 'start here
    Do While rng.Column <= 11
        'loop over the areas in the range
        For Each a In rng.Areas
            'edit 2 missed this entire check...
            If not Application.Intersect(a, Target) Is Nothing Then
                If Application.CountIf(a, Target.Value) > 1 Then
                    MsgBox Target.Value & " is already used in range " & a.Address, _
                           vbInformation, "Duplicate Entry!"
                    Exit Do
                End If
            End If

        Next a
        Set rng = rng.Offset(0, 2) 'move two columns to the right
    Loop

End Sub