如何将其他单元格区域添加到worksheet_change代码中，以一次评估一个区域？

时间：2019-01-05 07:54:14

标签： excel vba

我有一个月历，上面有各种作业。我有可以在日历上的单个范围内使用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

结束子

我现在尝试使用变量名称遍历所有范围。我使用带有多个或条件的If语句来定义不考虑的区域。我使用了一个If-ElseIf语句块来测试重复项。任何范围都不会调用MsgBox。

如何在所有15个范围内都启用此功能？

2 个答案:

答案 0 :(得分：0)

由蒂姆·威廉姆斯提供（见）

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

注意：此代码检查用户是否在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

非常感谢Tim给我展示了如何将庞大的代码简化为令人难以置信的简洁例程。

答案 1 :(得分：-1)

阅读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 之后，然后执行任何过程。请注意，它是私有的，这意味着它将仅在安装它的代码模块中可用。如果您在项目的其他地方也需要相同的编号，请将其设置为“公开”（只需删除“ 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

该过程首先检查Target是否在Union范围内的任何地方。然后将COUNTIF函数应用于Rng.Areas（NraSun2PM）。您可能希望循环执行此操作。由于区域1到15是连续的，因此您可以确定在哪个区域找到了匹配项，并对该信息进行了处理。作为替代方案，您可以创建一个特殊的序列，例如SunAM，它将是1，4，7，10，13，或者更好的是Array（NraSun1AM，NraSun2AM，NraSun3AM，NraSun4AM，NraSun5AM）。枚举的优点在这里很明显，因为命名变量使其更具可读性。但是，要点是，将来更改这些值时，可以在枚举中实现它们，而无需在任何过程中更改代码。无论可能是多少，NraSun5AM都将保持“ 5th Sunday AM”。 我希望这会有所帮助。

相关问题
最新问题