Combining two worksheet change events excel vba

BlokeMan

Board Regular
Joined
Aug 9, 2011
Messages
125
Hi,

I have tried to figure out how to combine the Worksheet_Change events below to run in the same worksheet.

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim aFullList As Variant, aRejects As Variant, vReject As Variant
  Dim aResults(1 To 30, 1 To 1) As Variant
  Dim i As Long, lSize As Long, k As Long
    
  If Not Intersect(Target, Union(Range("D2"), Range("I2:N18"))) Is Nothing Then
    lSize = Range("D2").Value
    If lSize > 0 Then
      aFullList = Application.Transpose(Evaluate("row(1:" & 30 * lSize & ")"))
      aRejects = Range("I2:N18").Value
      For Each vReject In aRejects
        If Not IsEmpty(vReject) Then
          aFullList(vReject) = "x"
        End If
      Next vReject
      aFullList = Filter(aFullList, "x", False)
      For i = lSize - 1 To UBound(aFullList) Step lSize
        k = k + 1
        aResults(k, 1) = aFullList(i)
      Next i
      If aResults(k, 1) <> aFullList(UBound(aFullList)) Then aResults(k + 1, 1) = aFullList(UBound(aFullList))
    End If
    Application.EnableEvents = False
    ActiveSheet.Unprotect Password:="xxx"
    Range("B2:B31").Value = aResults
    ActiveSheet.Protect Password:="xxx"
    Application.EnableEvents = True
  End If
End Sub

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim EvalRange As Range

'Set the range where you want to prevent duplicate entries.
    Set EvalRange = Range("I2:N18")
    
    '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, EvalRange) Is Nothing Or Target.Cells.Count > 1 Then Exit Sub
    If IsEmpty(Target) Then Exit Sub
    
    'If the value entered already exists in the defined range on the current worksheet, throw an
    'error message and undo the entry.
    If WorksheetFunction.CountIf(EvalRange, Target.Value) > 1 Then
        MsgBox Target.Value & " already exists on this sheet."
        Application.EnableEvents = False
        Target.ClearContents
        Application.EnableEvents = True
    End If
End Sub

Any help your guidance would be highly appreciated.
 

Some videos you may like

Excel Facts

What is the shortcut key for Format Selection?
Ctrl+1 (the number one) will open the Format dialog for whatever is selected.

Joe4

MrExcel MVP, Junior Admin
Joined
Aug 1, 2002
Messages
55,393
Office Version
  1. 365
Platform
  1. Windows
A lot of times, as long as the first one doesn't have any code to exit the sub, you can simply copy/paste the body for each under the other, like this:
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
  
' ***BLOCK 1***
  Dim aFullList As Variant, aRejects As Variant, vReject As Variant
  Dim aResults(1 To 30, 1 To 1) As Variant
  Dim i As Long, lSize As Long, k As Long
    
  If Not Intersect(Target, Union(Range("D2"), Range("I2:N18"))) Is Nothing Then
    lSize = Range("D2").Value
    If lSize > 0 Then
      aFullList = Application.Transpose(Evaluate("row(1:" & 30 * lSize & ")"))
      aRejects = Range("I2:N18").Value
      For Each vReject In aRejects
        If Not IsEmpty(vReject) Then
          aFullList(vReject) = "x"
        End If
      Next vReject
      aFullList = Filter(aFullList, "x", False)
      For i = lSize - 1 To UBound(aFullList) Step lSize
        k = k + 1
        aResults(k, 1) = aFullList(i)
      Next i
      If aResults(k, 1) <> aFullList(UBound(aFullList)) Then aResults(k + 1, 1) = aFullList(UBound(aFullList))
    End If
    Application.EnableEvents = False
    ActiveSheet.Unprotect Password:="xxx"
    Range("B2:B31").Value = aResults
    ActiveSheet.Protect Password:="xxx"
    Application.EnableEvents = True
  End If
  
' ***BLOCK 2***
Dim EvalRange As Range

'Set the range where you want to prevent duplicate entries.
    Set EvalRange = Range("I2:N18")
    
    '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, EvalRange) Is Nothing Or Target.Cells.Count > 1 Then Exit Sub
    If IsEmpty(Target) Then Exit Sub
    
    'If the value entered already exists in the defined range on the current worksheet, throw an
    'error message and undo the entry.
    If WorksheetFunction.CountIf(EvalRange, Target.Value) > 1 Then
        MsgBox Target.Value & " already exists on this sheet."
        Application.EnableEvents = False
        Target.ClearContents
        Application.EnableEvents = True
    End If
    
End Sub
See if that works for you.
 
Solution

BlokeMan

Board Regular
Joined
Aug 9, 2011
Messages
125
A lot of times, as long as the first one doesn't have any code to exit the sub, you can simply copy/paste the body for each under the other, like this:
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
 
' ***BLOCK 1***
  Dim aFullList As Variant, aRejects As Variant, vReject As Variant
  Dim aResults(1 To 30, 1 To 1) As Variant
  Dim i As Long, lSize As Long, k As Long
   
  If Not Intersect(Target, Union(Range("D2"), Range("I2:N18"))) Is Nothing Then
    lSize = Range("D2").Value
    If lSize > 0 Then
      aFullList = Application.Transpose(Evaluate("row(1:" & 30 * lSize & ")"))
      aRejects = Range("I2:N18").Value
      For Each vReject In aRejects
        If Not IsEmpty(vReject) Then
          aFullList(vReject) = "x"
        End If
      Next vReject
      aFullList = Filter(aFullList, "x", False)
      For i = lSize - 1 To UBound(aFullList) Step lSize
        k = k + 1
        aResults(k, 1) = aFullList(i)
      Next i
      If aResults(k, 1) <> aFullList(UBound(aFullList)) Then aResults(k + 1, 1) = aFullList(UBound(aFullList))
    End If
    Application.EnableEvents = False
    ActiveSheet.Unprotect Password:="xxx"
    Range("B2:B31").Value = aResults
    ActiveSheet.Protect Password:="xxx"
    Application.EnableEvents = True
  End If
 
' ***BLOCK 2***
Dim EvalRange As Range

'Set the range where you want to prevent duplicate entries.
    Set EvalRange = Range("I2:N18")
   
    '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, EvalRange) Is Nothing Or Target.Cells.Count > 1 Then Exit Sub
    If IsEmpty(Target) Then Exit Sub
   
    'If the value entered already exists in the defined range on the current worksheet, throw an
    'error message and undo the entry.
    If WorksheetFunction.CountIf(EvalRange, Target.Value) > 1 Then
        MsgBox Target.Value & " already exists on this sheet."
        Application.EnableEvents = False
        Target.ClearContents
        Application.EnableEvents = True
    End If
   
End Sub
See if that works for you.
This is the first thing that I've done and I'm getting "Run-time error 1004" on "Target.ClearContents", my mistake. Amended the code below.

Code:
Application.EnableEvents = False
        ActiveSheet.Unprotect Password:="xxx"
        Target.ClearContents
        ActiveSheet.Protect Password:="xxx"
        Application.EnableEvents = True

Thanks Joe4
 

Joe4

MrExcel MVP, Junior Admin
Joined
Aug 1, 2002
Messages
55,393
Office Version
  1. 365
Platform
  1. Windows
So, does that mean the issue is now resolved?
I see you marked a solution, but your last post left me a little unclear as to whether or not there are still issues.
 

Joe4

MrExcel MVP, Junior Admin
Joined
Aug 1, 2002
Messages
55,393
Office Version
  1. 365
Platform
  1. Windows
Excellent!
You are welcome.
 

Watch MrExcel Video

Forum statistics

Threads
1,118,294
Messages
5,571,379
Members
412,385
Latest member
OChambo94
Top