Как добавить другие диапазоны ячеек в код worksheet_change для оценки одного диапазона за раз?

Question

У меня есть месячный календарь с различными заданиями. У меня есть код, который работает с использованием Private Sub Worksheet_Change для одного диапазона в календаре. Этот код отображает предупреждение в окне сообщения, когда для второй задачи в тот же период времени (одинаковый диапазон ячеек) выбрано повторяющееся значение [имена людей]. Я хочу сделать это для 15 различных диапазонов на одном листе. Каждый диапазон должен считаться независимым от других диапазонов. Другими словами, одно и то же [имя] может быть в другой день без каких-либо предупреждений.

Я нашел некоторый код и изменил его, чтобы сделать то, что мне нужно, и он работает для первого диапазона, но у меня может быть только один worksheet_change на этом листе. Я не знаю, как использовать один и тот же код с несколькими диапазонами. Я определил (DIM xxx as range) для каждого диапазона, а SET xxx = range(ccc) назначил диапазон для каждой переменной.

Как включить другие диапазоны?

Private Sub Worksheet_Change(ByVal Target As Range)
'Define your variables.
Dim Sun1AM, Sun1PM, Wed1PM As Range
Dim Sun2AM, Sun2PM, Wed2PM As Range
Dim Sun3AM, Sun3PM, Wed3PM As Range
Dim Sun4AM, Sun4PM, Wed4PM As Range
Dim Sun5AM, Sun5PM, Wed5PM As Range

'Set the range 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")

'If the cell where value was entered is not in the defined range,
'if the value pasted is larger than a single cell,
'or if no value was entered in the cell, then exit the macro.
If Intersect(Target, Sun1AM) Is Nothing Or Intersect(Target, Sun1PM) Is Nothing Or _
Intersect(Target, Wed1PM) Is Nothing Or Intersect(Target, Sun2AM) Is Nothing Or _
Intersect(Target, Sun2PM) Is Nothing Or Intersect(Target, Wed2PM) Is Nothing Or _
Intersect(Target, Sun3AM) Is Nothing Or Intersect(Target, Sun3PM) Is Nothing Or _
Intersect(Target, Wed3PM) Is Nothing Or Intersect(Target, Sun4AM) Is Nothing Or _
Intersect(Target, Sun4PM) Is Nothing Or Intersect(Target, Wed4PM) Is Nothing Or _
Intersect(Target, Sun5AM) Is Nothing Or Intersect(Target, Sun5PM) Is Nothing Or _
Intersect(Target, Wed5PM) Is Nothing Or IsEmpty(Target) _
Then Exit Sub

'If the value entered already exists in the defined range on the current worksheet, throw an
'error message.
If WorksheetFunction.CountIf(Sun1AM, Target.Value) > 1 Then
    MsgBox Target.Value & " is already used.", vbInformation, "Duplicate Entry!"
    Application.EnableEvents = False
    Application.EnableEvents = True
 ElseIf WorksheetFunction.CountIf(Sun1PM, Target.Value) > 1 Then
    MsgBox Target.Value & " is already used.", vbInformation, "Duplicate Entry!"
    Application.EnableEvents = False
    Application.EnableEvents = True
 ElseIf WorksheetFunction.CountIf(Wed1PM, Target.Value) > 1 Then
    MsgBox Target.Value & " is already used.", vbInformation, "Duplicate Entry!"
    Application.EnableEvents = False
    Application.EnableEvents = True
 ElseIf WorksheetFunction.CountIf(Sun2AM, Target.Value) > 1 Then
    MsgBox Target.Value & " is already used.", vbInformation, "Duplicate Entry!"
    Application.EnableEvents = False
    Application.EnableEvents = True
 ElseIf WorksheetFunction.CountIf(Sun2PM, Target.Value) > 1 Then
    MsgBox Target.Value & " is already used.", vbInformation, "Duplicate Entry!"
    Application.EnableEvents = False
    Application.EnableEvents = True
 ElseIf WorksheetFunction.CountIf(Wed2PM, Target.Value) > 1 Then
    MsgBox Target.Value & " is already used.", vbInformation, "Duplicate Entry!"
    Application.EnableEvents = False
    Application.EnableEvents = True
 ElseIf WorksheetFunction.CountIf(Sun3AM, Target.Value) > 1 Then
    MsgBox Target.Value & " is already used.", vbInformation, "Duplicate Entry!"
    Application.EnableEvents = False
    Application.EnableEvents = True
 ElseIf WorksheetFunction.CountIf(Sun3PM, Target.Value) > 1 Then
    MsgBox Target.Value & " is already used.", vbInformation, "Duplicate Entry!"
    Application.EnableEvents = False
    Application.EnableEvents = True
 ElseIf WorksheetFunction.CountIf(Wed3PM, Target.Value) > 1 Then
    MsgBox Target.Value & " is already used.", vbInformation, "Duplicate Entry!"
    Application.EnableEvents = False
    Application.EnableEvents = True
 ElseIf WorksheetFunction.CountIf(Sun4AM, Target.Value) > 1 Then
    MsgBox Target.Value & " is already used.", vbInformation, "Duplicate Entry!"
    Application.EnableEvents = False
    Application.EnableEvents = True
 ElseIf WorksheetFunction.CountIf(Sun4PM, Target.Value) > 1 Then
    MsgBox Target.Value & " is already used.", vbInformation, "Duplicate Entry!"
    Application.EnableEvents = False
    Application.EnableEvents = True
 ElseIf WorksheetFunction.CountIf(Wed4PM, Target.Value) > 1 Then
    MsgBox Target.Value & " is already used.", vbInformation, "Duplicate Entry!"
    Application.EnableEvents = False
    Application.EnableEvents = True
 ElseIf WorksheetFunction.CountIf(Sun5AM, Target.Value) > 1 Then
    MsgBox Target.Value & " is already used.", vbInformation, "Duplicate Entry!"
    Application.EnableEvents = False
    Application.EnableEvents = True
 ElseIf WorksheetFunction.CountIf(Sun5PM, Target.Value) > 1 Then
    MsgBox Target.Value & " is already used.", vbInformation, "Duplicate Entry!"
    Application.EnableEvents = False
    Application.EnableEvents = True
 ElseIf WorksheetFunction.CountIf(Wed5PM, Target.Value) > 1 Then
    MsgBox Target.Value & " is already used.", vbInformation, "Duplicate Entry!"
    Application.EnableEvents = False
    Application.EnableEvents = True
End If

End Sub

Теперь я попытался перебрать все диапазоны, используя имена переменных. Я использовал оператор If с несколькими условиями Or для определения областей, которые не следует рассматривать. Я использовал блок If - ElseIf для проверки дубликатов. Ни один из диапазонов не вызовет MsgBox.

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

Answer 1

Ответ любезно предоставлен Тимом Уильямсом (см.)

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

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 _   'make sure the target is in this range
       And WorksheetFunction.CountIf(a, Target.Value) > 1 Then  'check for duplicates
        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 2

Ознакомьтесь с функцией Application.Union, которая позволяет объединять отдельные области листа в диапазон, к которому может обращаться одно имя. В пределах этого диапазона каждая область имеет последовательный номер. Поэтому вы можете обратиться к каждому частичному диапазону. Функция ниже создаст диапазон объединения всех диапазонов, которые вам нужно определить.

Private Function SetRanges() As Range
    ' 05 Jan 2019

    Dim Fun As Range                            ' function return value
    Dim Rng As Range
    Dim RowNums As Variant
    Dim C As Integer, R As Integer

    RowNums = Array(4, 14, 17, 21, 24, 28)

    For C = 3 To 11 Step 2
        For R = 0 To UBound(RowNums) Step 2
            Set Rng = Range(Cells(RowNums(R), C), Cells(RowNums(R + 1), C))
            If Fun Is Nothing Then
                Set Fun = Rng
            Else
                Set Fun = Application.Union(Fun, Rng)
            End If
        Next R
    Next C
    Set SetRanges = Fun
End Function

Установите его в нижней части модуля кода рабочего листа, на котором у вас есть процедура события Change. Эта функция создаст диапазон из 15 областей. Лучший способ идентифицировать их - создать перечисление, подобное приведенному ниже.

Private Enum Nra                        ' Range Area IDs
    ' 05 Jan 2019
    NraSun1AM = 1
    NraSun1PM
    NraWed1PM
    NraSun2AM
    NraSun2PM
    NraWed2PM
    NraSun3AM
    NraSun3PM
    NraWed3PM
    NraSun4AM
    NraSun4PM
    NraWed4PM
    NraSun5AM
    NraSun5PM
    NraWed5PM
End Enum

Перечисление должно находиться в самом верху таблицы кода, сразу после Option Explicit и перед любыми процедурами. Обратите внимание, что это личное, то есть оно будет доступно только в модуле кода, где он установлен. Если вам нужны те же номера и в других местах вашего проекта, сделайте его Public (просто удалите «Private») и переместите его в стандартный модуль кода в том же проекте. Попробуйте небольшую процедуру ниже, чтобы увидеть, как работает установка. Обратите внимание, что вы можете обратиться к диапазону объединения либо напрямую, либо присвоить его области другому объекту диапазона.

Private Sub TestRanges()
    Debug.Print SetRanges.Areas(NraSun2AM).Address

    Dim Rng As Range
    Set Rng = SetRanges.Areas(NraSun4AM)
    Debug.Print Rng.Address
End Sub

С этого момента я не уверен, как вы представляете, как работает ваша система. Ниже приведен план вашего события изменения.

Private Sub Worksheet_Change(ByVal Target As Range)
    ' 05 Jan 2019

    Dim Rng As Range

    ' if the value pasted is larger than a single cell,
    If Target.Cells.Count > 1 Then Exit Sub

    If Len(Target.Value) Then
        Set Rng = SetRanges
        'If the cell where value was entered is not in the defined range,
        If Not Application.Intersect(Target, Rng) Is Nothing Then
            'If the value entered already exists in the defined range
            'on the current worksheet, throw an error message.
            If WorksheetFunction.CountIf(Rng.Areas(NraSun2PM), Target.Value) > 1 Then
                MsgBox Target.Value & " is already used.", vbInformation, "Duplicate Entry!"
'                Application.EnableEvents = False
'                Application.EnableEvents = True
            End If
    End If

Процедура сначала проверяет, находится ли цель в каком-либо диапазоне диапазона. Затем он применяет функцию COUNTIF к Rng.Areas (NraSun2PM). Вы можете сделать это в цикле. Поскольку области с 1 по 15 являются последовательными, вы можете определить, в какой из них найдено совпадение, и что-то сделать с этой информацией. В качестве альтернативы вы можете создать специальную последовательность, такую ​​как SunAM, которая будет 1, 4, 7, 10, 13 или, что лучше, Array (NraSun1AM, NraSun2AM, NraSun3AM, NraSun4AM, NraSun5AM). Преимущество перечисления здесь ясно, потому что именованные переменные делают его более читаемым. Суть, однако, заключается в том, что когда в будущем у вас будут изменения в этих значениях, они будут реализованы в перечислении без необходимости изменения кода в каких-либо процедурах. NraSun5AM остается "5-е воскресенье утра", каким бы числом оно ни было. Надеюсь, это поможет.