How do I add other cell ranges to a worksheet_change code to evaluate one range at a time?

0
votes

I have a monthly calendar with various assignments on it. I have code that works using Private Sub Worksheet_Change for a single range on the calendar. This code displays a message box warning when a duplicate value [persons name] is selected for a second task in the same time period (same range of cells). I want to do this for 15 different ranges on the same worksheet. Each range should be considered independent of the other ranges. In other words the same [name] can be on a different day without any warning message box.

I found some code and modified it to do what I need and it works for the first range, but I can only have one worksheet_change on this worksheet. I don't know how to use the same code with multiple ranges. I defined (DIM xxx as range) for each range and SET xxx = range(ccc) assigning the range for each variable.

How do I enable the other ranges?

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

I now tried looping through all the ranges by using the variable names. I used an If statement with several Or conditions to define areas not to be considered. I used a block If - ElseIf statement to test for duplicates. None of the ranges will call up the MsgBox.

How can I make this active for all 15 ranges?

2
excelvba
I defined (DIM xxx as range) for each range - no you didn't. You defined Wed1PM, Wed2PM, Wed3PM, Wed4PM, Wed5PM as Range and the rest as Variant. – GSerg
You have your logic backwards. Worksheet_Change tells you which cells changed. You don't need to check the ranges the current instance of Worksheet_Change is not telling you about, because these have not changed since it last time fired. You explicitly want to only run the code when Target is a single cell (If ... Target.Cells.Count > 1 Then Exit Sub), so you do in fact want to only check one of the possible ranges, not all. You just need to tell which one to test, and you do that by calling Application.Intersect on all your Range variables until you get a match. – GSerg
@GSerg, why not intersect target with a union of the possible 'island' ranges? – user10862412
@user10862412 Because then you won't be able to tell which range gave the match, and like it is stated above, "Each range should be considered independent of the other ranges. In other words the same [name] can be on a different day without any warning message box." – GSerg
@GSerg, My bad and you're right of course. I've proposed a possible alternative below but it is dependent upon truly blank rows and columns separating the range Area 'islands' and that has not been guaranteed. The longhand option would be looping through the Areas of the Union. – user10862412

2 Answers

0
votes

Answer courtesy of Tim Williams (see)

How can I make a loop to run this code 15 times using a list of the range variables I defined?

https://stackoverflow.com/users/478884/tim-williams

Note: this code checks for the user entering a duplicate value in the ranges 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 only.

These are static ranges of assignments on a dynamic monthly assignment calendar. This code does not delete or prevent a duplicate entry. It only advises the user with a vbInformation message box that a person has been assigned more than one task on a given day. It notifies that "someone" has already been used, and the user may choose to leave or edit the duplicate. This sheet (a master copy) is copied as a new blank sheet for each month, assignments are filled in and printed copies are distributed. The sheet itself changes dynamically to reflect the proper calendar dates once a month and year are chosen. This code is designed to work on the "active" worksheet since only one month (one sheet) is being assigned at a time, and past months remain as reference documents.

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

Many thanks to Tim for showing me how to simplify my bulky code to an incredibly neat and simple routine.

-1
votes

Read up in on Application.Union function which allows you to join disconnected areas of a worksheet into a range that can be addressed by a single name. Within this range each area has a consecutive number. Therefore you can address each partial range. The function below will create a Union range of all the ranges you need to define.

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

Install it at the bottom of the code module of the worksheet on which you have the Change event procedure. This function will produce a range with 15 areas. The best way to identify them is to create an enumeration, like the one below.

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

The enum must be at the very top of the code sheet, just after Option Explicit and before any procedures. Observe that it is private, meaning it will be available only in the code module where it is installed. If you need the same numbers also elsewhere in your project make it Public (just remove the "Private") and move it to a standard code module in the same project. Try the little procedure below to see how the setup works. Observe that you can refer to the Union range either directly or assign areas of it to another range object.

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

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

From here on, I am not sure how you imagine your system to work, exactly. Below is the blueprint for your change event however.

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

The procedure first checks if Target is anywhere in the Union range. Then it applies the COUNTIF function to Rng.Areas(NraSun2PM). You may wish to do this in a loop. Since the areas 1 to 15 are consecutive you could identify in which of them a match is found and do something with that info. As an alternative you might create a special sequence, like SunAM, which would be 1, 4, 7, 10, 13 or, better, Array(NraSun1AM, NraSun2AM, NraSun3AM, NraSun4AM, NraSun5AM). The advantage of the enum is made clear here because the named variables make it more readable. The main point, however, is that when you have changes in these values in the future they are implemented in the enumeration without the need of changing the code in any procedures. NraSun5AM remains "5th Sunday AM" whatever number that might be. I hope this helps.