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.
 

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.
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.
 
Upvote 0
Solution
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
 
Upvote 0
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.
 
Upvote 0
Excellent!
You are welcome.
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,210
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top