Private Sub Worksheet Change - Multiple on same worksheet

poulet · Feb 13th 2017

What is the best way to incorporate more than one Private Sub Worksheet Change in one sheet?

Is there a work around using modules?

Here is the code, I can't have all 3 work at the same time. They all do different things.

I might even add more Private Sub Worksheet Change and I am trying to find the easiest way to run them.

Code

Private Sub Worksheet_Change(ByVal Target As Range)


On Error Resume Next


Dim ws As Worksheet


Dim str As String


Dim i As Integer


Dim rngDV As Range


Dim rng As Range


 


If Target.Count > 1 Then Exit Sub


Set ws = Worksheets("DD")


 


If Target.Row > 1 Then


  On Error Resume Next


  Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)


  On Error GoTo 0


  If rngDV Is Nothing Then Exit Sub


 


  If Intersect(Target, rngDV) Is Nothing Then Exit Sub


 


  str = Target.Validation.Formula1


  str = Right(str, Len(str) - 1)


  On Error Resume Next


  Set rng = ws.Range(str)


  On Error GoTo 0


  If rng Is Nothing Then Exit Sub


 


  If Application.WorksheetFunction _


    .CountIf(rng, Target.Value) Then


    Exit Sub


  Else


    i = ws.Cells(Rows.Count, rng.Column).End(xlUp).Row + 1


    ws.Cells(i, rng.Column).Value = Target.Value


    rng.Sort Key1:=ws.Cells(1, rng.Column), _


      Order1:=xlAscending, Header:=xlNo, _


      OrderCustom:=1, MatchCase:=False, _


      Orientation:=xlTopToBottom


  End If


 


End If


 


End Sub


 


 


 


'https://www.mrexcel.com/forum/excel-questions/457000-macro-prevent-duplicate-entries.html


Private Sub Worksheet_Change(ByVal Target As Range)


With Target


If .Column <> 2 Or .Cells.Count > 1 Then Exit Sub


If WorksheetFunction.CountIf(Columns(.Column), .Value) > 1 Then


Application.DisplayAlerts = False


.ClearContents


Application.DisplayAlerts = True


MsgBox "This PGRB code has previously been used. You can't use the same code twice."


End If


End With


End Sub


 


 


'https://www.mrexcel.com/forum/excel-questions/918896-show-last-date-modified-every-row.html


Private Sub Worksheet_Change(ByVal Target As Range)


Define variable


Dim Cell As Range


' If you update any cell in column O (update as required) then...


    If Not Intersect(Target, Range("B:B")) Is Nothing Then


' If only one cell is updated then...


        If Target.Cells.Count = 1 Then


' Timestamp column P of the target row


            Range("C" & Target.Row).Value = Now()


' Else if more than one cell is updated at once then...


        Else


' For each cell in the selection


            For Each Cell In Selection


' If the updated value is not blank


                If Cell.Value <> "" Then


' Timestamp column P of the target row


                    Range("C" & Cell.Row).Value = Now()


                End If


' Check next cell in selection


            Next Cell


        End If


    End If


End Sub

Display More

**StephenR** · Feb 13th 2017

Re: Private Sub Worksheet Change - Multiple on same worksheet

Code

Private Sub Worksheet_Change(ByVal Target As Range)


    Dim ws As Worksheet
    Dim str As String
    Dim i As Integer
    Dim rngDV As Range
    Dim rng As Range
     
    If Target.Count > 1 Then Exit Sub
    
    Set ws = Worksheets("DD")
     
    If Target.Row > 1 Then
        'code as before
    End If
    If Target.Column = 2 Then
        'incorporate other two bits of code
    End If
     
End Sub

Display More

poulet · Feb 13th 2017

Re: Private Sub Worksheet Change - Multiple on same worksheet

Thank you StephenR.

Being pretty new to VB, could you show me the full code?

I tried but I am getting errors. Maybe I have to remove something and not paste the entire code?

I will copy this code in my worksheet named Input.
Thank you.

**StephenR** · Feb 13th 2017

Re: Private Sub Worksheet Change - Multiple on same worksheet

I think this is right.

Code

Private Sub Worksheet_Change(ByVal Target As Range)


Dim ws As Worksheet
Dim str As String
Dim i As Integer
Dim rngDV As Range
Dim rng As Range
Dim cell As Range


Set ws = Worksheets("DD")


If Target.Row > 1 Then
    If Target.Count > 1 Then Exit Sub
    On Error Resume Next
    Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
    On Error GoTo 0
    If rngDV Is Nothing Then Exit Sub
    If Intersect(Target, rngDV) Is Nothing Then Exit Sub
    str = Target.Validation.Formula1
    str = Right(str, Len(str) - 1)
    On Error Resume Next
    Set rng = ws.Range(str)
    On Error GoTo 0
    If rng Is Nothing Then Exit Sub
    If Application.WorksheetFunction.CountIf(rng, Target.Value) Then Exit Sub
Else
    i = ws.Cells(Rows.Count, rng.Column).End(xlUp).Row + 1
    ws.Cells(i, rng.Column).Value = Target.Value
    rng.Sort Key1:=ws.Cells(1, rng.Column), _
        Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom
End If


If Target.Column = 2 Then
    If WorksheetFunction.CountIf(Columns(target.Column), target.Value) > 1 Then
        Application.DisplayAlerts = False
        target.ClearContents
        Application.DisplayAlerts = True
        MsgBox "This PGRB code has previously been used. You can't use the same code twice."
    End If
    For Each cell In Target
        If cell.Value <> "" Then
            Range("C" & cell.Row).Value = Now()
        End If
    Next cell
End If


End Sub

Display More

poulet · Feb 13th 2017

Re: Private Sub Worksheet Change - Multiple on same worksheet

I am not getting any errors but it is not working.

For example, one code is used to block a user from entering the same value twice in a column...however, I can now.

The time stamp code is not present...

Code

'https://www.mrexcel.com/forum/excel-questions/918896-show-last-date-modified-every-row.html
 
Private Sub Worksheet_Change(ByVal Target As Range) 
     
    Define variable 
     
    Dim Cell As Range 
     
     ' If you update any cell in column O (update as required) then...
     
    If Not Intersect(Target, Range("B:B")) Is Nothing Then 
         
         ' If only one cell is updated then...
         
        If Target.Cells.Count = 1 Then 
             
             ' Timestamp column P of the target row
             
            Range("C" & Target.Row).Value = Now() 
             
             ' Else if more than one cell is updated at once then...
             
        Else 
             
             ' For each cell in the selection
             
            For Each Cell In Selection 
                 
                 ' If the updated value is not blank
                 
                If Cell.Value <> "" Then 
                     
                     ' Timestamp column P of the target row
                     
                    Range("C" & Cell.Row).Value = Now() 
                     
                End If 
                 
                 ' Check next cell in selection
                 
            Next Cell 
             
        End If 
         
    End If 
     
End Sub

Display More

Thanks again for taking the time to help me with VBA. I appreciate

poulet · Feb 13th 2017

Re: Private Sub Worksheet Change - Multiple on same worksheet

The 3 different works perfectly if used once at a time, however, the are not working when they are all used at the same time in the same worksheet.

Btw, I have 2 sheets, one call input will all my information and one called DD will all my various drop downs options

poulet · Feb 13th 2017

Re: Private Sub Worksheet Change - Multiple on same worksheet

Would it be possible to have one module for each code and have them called in my Input worksheet? For example, have one module for each of my 3 codes?

**StephenR** · Feb 13th 2017

Re: Private Sub Worksheet Change - Multiple on same worksheet

Spotted some gremlins. Try this instead

Code

Private Sub Worksheet_Change(ByVal Target As Range)


Dim ws As Worksheet
Dim str As String
Dim i As Integer
Dim rngDV As Range
Dim rng As Range
Dim cell As Range


Set ws = Worksheets("DD")
'Stop
If Target.Row > 1 Then
    If Target.Count > 1 Then Exit Sub
    On Error Resume Next
    Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
    On Error GoTo 0
    If Not rngDV Is Nothing Then
        If Not Intersect(Target, rngDV) Is Nothing Then
            str = Target.Validation.Formula1
            str = Right(str, Len(str) - 1)
            On Error Resume Next
            Set rng = ws.Range(str)
            On Error GoTo 0
            If Not rng Is Nothing Then
                If Not Application.WorksheetFunction.CountIf(rng, Target.Value) Then
                    i = ws.Cells(Rows.Count, rng.Column).End(xlUp).Row + 1
                    ws.Cells(i, rng.Column).Value = Target.Value
                    rng.Sort Key1:=ws.Cells(1, rng.Column), _
                        Order1:=xlAscending, Header:=xlNo, _
                        OrderCustom:=1, MatchCase:=False, _
                        Orientation:=xlTopToBottom
                End If
            End If
        End If
    End If
End If


If Target.Column = 2 Then
    If Target.Count = 1 Then
        If WorksheetFunction.CountIf(Columns(Target.Column), Target.Value) > 1 Then
            Application.DisplayAlerts = False
            Target.ClearContents
            Application.DisplayAlerts = True
            MsgBox "This PGRB code has previously been used. You can't use the same code twice."
        End If
    End If
    For Each cell In Target
        If cell.Value <> "" Then
            Range("C" & cell.Row).Value = Now()
        End If
    Next cell
End If


End Sub

Display More

poulet · Feb 13th 2017

Re: Private Sub Worksheet Change - Multiple on same worksheet

You are a very smart man. Thanks for sharing your valuable time. It is almost perfect.

The first code in the list was to have my drop down lists in sheet DD updated if a user saw the choice was not available then he could just write it in the drop down box, press enter and it would appear in the drop down menu options pulled from worksheet DD.

This part is partially working. The issue I get now is multiple items are being repeated in my drop down options (duplications) pulled from worksheet DD.

**StephenR** · Feb 13th 2017

Re: Private Sub Worksheet Change - Multiple on same worksheet

If this doesn't work, can you post a workbook?

Code

Private Sub Worksheet_Change(ByVal Target As Range)
     
    Dim ws As Worksheet
    Dim str As String
    Dim i As Integer
    Dim rngDV As Range
    Dim rng As Range
    Dim cell As Range
     
    Set ws = Worksheets("DD")
    
    If Target.Row > 1 Then
        If Target.Count > 1 Then Exit Sub
        On Error Resume Next
        Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
        On Error GoTo 0
        If Not rngDV Is Nothing Then
            If Not Intersect(Target, rngDV) Is Nothing Then
                str = Target.Validation.Formula1
                str = Right(str, Len(str) - 1)
                On Error Resume Next
                Set rng = ws.Range(str)
                On Error GoTo 0
                If Not rng Is Nothing Then
                    If WorksheetFunction.CountIf(rng, Target.Value) = 0 Then
                        i = ws.Cells(Rows.Count, rng.Column).End(xlUp).Row + 1
                        ws.Cells(i, rng.Column).Value = Target.Value
                        rng.Sort Key1:=ws.Cells(1, rng.Column), _
                        Order1:=xlAscending, Header:=xlNo, _
                        OrderCustom:=1, MatchCase:=False, _
                        Orientation:=xlTopToBottom
                    End If
                End If
            End If
        End If
    End If
     
    If Target.Column = 2 Then
        If Target.Count = 1 Then
            If WorksheetFunction.CountIf(Columns(Target.Column), Target.Value) > 1 Then
                Application.DisplayAlerts = False
                Application.EnableEvents = False
                Target.ClearContents
                Application.EnableEvents = True
                Application.DisplayAlerts = True
                MsgBox "This PGRB code has previously been used. You can't use the same code twice."
            End If
        End If
        For Each cell In Target
            If cell.Value <> "" Then
                Application.EnableEvents = False
                Range("C" & cell.Row).Value = Now()
                Application.EnableEvents = True
            End If
        Next cell
    End If
     
End Sub

Display More

poulet · Feb 13th 2017

Re: Private Sub Worksheet Change - Multiple on same worksheet

No needs. Works perfectly now.

Can I copy this code right under code above? It is not a worksheet change but a selection change. Not sure if this makes a difference?

Code

Option Explicit


' Developed by Contextures Inc.


' www.contextures.com http://www.contextures.com/excelfiles.html CM0002


Private Sub Worksheet_SelectionChange(ByVal Target As Range)


Dim wsCmt As Worksheet


Dim strCmt As String


Dim rngCmt As Range


Set wsCmt = Worksheets("Comments")


Set rngCmt = wsCmt.Range("Comments")


 


On Error Resume Next


strCmt = Application.WorksheetFunction.VLookup(Target.Value, rngCmt, 2, 0)


Range("E2").Value = strCmt


 


End Sub

Display More

StephenR, thanks again!!

**StephenR** · Feb 13th 2017

Re: Private Sub Worksheet Change - Multiple on same worksheet

Glad we got there. You must keep that one separate but in the same sheet module.

poulet · Feb 14th 2017

Re: Private Sub Worksheet Change - Multiple on same worksheet

OK, not sure I understand this one...

I paste it in the worksheet file VBA right under the current code (see above)

When I do, I get the following error : compile error only comments may appear after end sub, end function, or end property.

Code

Private Sub Worksheet_Change(ByVal Target As Range)


    


    Dim ws As Worksheet


    Dim str As String


    Dim i As Integer


    Dim rngDV As Range


    Dim rng As Range


    Dim cell As Range


    


    Set ws = Worksheets("DD")


    


    If Target.Row > 1 Then


        If Target.Count > 1 Then Exit Sub


        On Error Resume Next


        Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)


        On Error GoTo 0


        If Not rngDV Is Nothing Then


            If Not Intersect(Target, rngDV) Is Nothing Then


                str = Target.Validation.Formula1


                str = Right(str, Len(str) - 1)


                On Error Resume Next


                Set rng = ws.Range(str)


                On Error GoTo 0


                If Not rng Is Nothing Then


                    If WorksheetFunction.CountIf(rng, Target.Value) = 0 Then


                        i = ws.Cells(Rows.Count, rng.Column).End(xlUp).Row + 1


                        ws.Cells(i, rng.Column).Value = Target.Value


                        rng.Sort Key1:=ws.Cells(1, rng.Column), _


                        Order1:=xlAscending, Header:=xlNo, _


                        OrderCustom:=1, MatchCase:=False, _


                        Orientation:=xlTopToBottom


                    End If


                End If


            End If


        End If


    End If


    


    If Target.Column = 2 Then


        If Target.Count = 1 Then


            If WorksheetFunction.CountIf(Columns(Target.Column), Target.Value) > 1 Then


                Application.DisplayAlerts = False


                Application.EnableEvents = False


                Target.ClearContents


                Application.EnableEvents = True


                Application.DisplayAlerts = True


                MsgBox "Sorry, but you can't use the same PRGB code twice."


            End If


        End If


        For Each cell In Target


            If cell.Value <> "" Then


                Application.EnableEvents = False


                Range("C" & cell.Row).Value = Now()


                Application.EnableEvents = True


            End If


        Next cell


    End If


    


End Sub


 ' code below with code above is giving me an error message


Option Explicit


' Developed by Contextures Inc.


' www.contextures.com http://www.contextures.com/excelfiles.html CM0002


Private Sub Worksheet_SelectionChange(ByVal Target As Range)


Dim wsCmt As Worksheet


Dim strCmt As String


Dim rngCmt As Range


Set wsCmt = Worksheets("Comments")


Set rngCmt = wsCmt.Range("Comments")


 


On Error Resume Next


strCmt = Application.WorksheetFunction.VLookup(Target.Value, rngCmt, 2, 0)


Range("E2").Value = strCmt


 


End Sub

Display More

**StephenR** · Feb 14th 2017

Re: Private Sub Worksheet Change - Multiple on same worksheet

Remove 'Option Explicit'. This should only appear at the top of the module (and should be set to appear automatically anyway).

poulet · Feb 14th 2017

Re: Private Sub Worksheet Change - Multiple on same worksheet

This code is in my Microsoft Excel Objects Sheet 1 (input)

When I remove the option explicit line, I get the following error : Run-time error 28 Out of Stack Space. If I click debug, the Set rngcmt = wsCmt.Range("comments") line is highlighted yellow.

**StephenR** · Feb 14th 2017

Re: Private Sub Worksheet Change - Multiple on same worksheet

Do you really intend for a look up to be done every time a cell is selected?

poulet · Feb 14th 2017

Re: Private Sub Worksheet Change - Multiple on same worksheet

Each time a cell in my table first column is selected, it will show the comment located in the comments sheet.

**StephenR** · Feb 14th 2017

Re: Private Sub Worksheet Change - Multiple on same worksheet

At the moment it's activated by selecting any cell. This is straying somewhat from the original question, but time I think to attach a simplified workbook with enough to demonstrate your problem.

poulet · Feb 14th 2017

Re: Private Sub Worksheet Change - Multiple on same worksheet

Thanks.

When I click on a cell in the first column of my input worksheet, the comment I wrote in the comments worksheet (if it match the exact PGRB code) is pulled and shown on my input page worksheet.
Each time a cell in my table first column is selected, it will show the comment inputted in the comments worksheet. The comment will only appear when a cell in the first column is selected and has a comment or not (empty).

Obtained from

' Developed by Contextures Inc.

' http://www.contextures.com http://www.contextures.com/excelfiles.html CM0002

If not clear I'll try to post an empty template.

Basically, I am just copying the Ozgrid code.

poulet · Feb 15th 2017

Re: Private Sub Worksheet Change - Multiple on same worksheet

OK, I revised the last part to (see below), the good : no errors, the bad : not working.

Code

Private Sub Workbook_SheetActivate(ByVal Sh As Object)


 


Call Commentaires


 


End Sub


 


' Developed by Contextures Inc.


' www.contextures.com http://www.contextures.com/excelfiles.html CM0002


Sub Commentaires()


Dim wsCmt As Worksheet


Dim strCmt As String


Dim rngCmt As Range


Set wsCmt = Worksheets("Comments")


Set rngCmt = wsCmt.Range("Comments")


 


On Error Resume Next


strCmt = Application.WorksheetFunction.VLookup(Target.Value, rngCmt, 2, 0)


Range("E2").Value = strCmt


 


End Sub

Display More

Full code in the Input worksheet is :

Code

Private Sub Worksheet_Change(ByVal Target As Range)


    


    Dim ws As Worksheet


    Dim str As String


    Dim i As Integer


   Dim rngDV As Range


    Dim rng As Range


    Dim cell As Range


    


    Set ws = Worksheets("DD")


    


    If Target.Row > 1 Then


        If Target.Count > 1 Then Exit Sub


        On Error Resume Next


        Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)


        On Error GoTo 0


        If Not rngDV Is Nothing Then


            If Not Intersect(Target, rngDV) Is Nothing Then


                str = Target.Validation.Formula1


                str = Right(str, Len(str) - 1)


                On Error Resume Next


                Set rng = ws.Range(str)


                On Error GoTo 0


                If Not rng Is Nothing Then


                    If WorksheetFunction.CountIf(rng, Target.Value) = 0 Then


                        i = ws.Cells(Rows.Count, rng.Column).End(xlUp).Row + 1


                        ws.Cells(i, rng.Column).Value = Target.Value


                        rng.Sort Key1:=ws.Cells(1, rng.Column), _


                        Order1:=xlAscending, Header:=xlNo, _


                        OrderCustom:=1, MatchCase:=False, _


                        Orientation:=xlTopToBottom


                    End If


                End If


            End If


        End If


    End If


    


    If Target.Column = 2 Then


        If Target.Count = 1 Then


            If WorksheetFunction.CountIf(Columns(Target.Column), Target.Value) > 1 Then


                Application.DisplayAlerts = False


                Application.EnableEvents = False


                Target.ClearContents


                Application.EnableEvents = True


                Application.DisplayAlerts = True


                MsgBox "This PGRB code has previously been used. You can't use the same code twice."


            End If


        End If


        For Each cell In Target


            If cell.Value <> "" Then


                Application.EnableEvents = False


                Range("C" & cell.Row).Value = Now()


                Application.EnableEvents = True


            End If


        Next cell


    End If


    


End Sub


 


 


Private Sub Workbook_SheetActivate(ByVal Sh As Object)


 


Call Commentaires


 


End Sub


 


' Developed by Contextures Inc.


' www.contextures.com http://www.contextures.com/excelfiles.html CM0002


Sub Commentaires()


Dim wsCmt As Worksheet


Dim strCmt As String


Dim rngCmt As Range


Set wsCmt = Worksheets("Comments")


Set rngCmt = wsCmt.Range("Comments")


 


On Error Resume Next


strCmt = Application.WorksheetFunction.VLookup(Target.Value, rngCmt, 2, 0)


Range("E2").Value = strCmt


 


End Sub

Display More

Private Sub Worksheet Change - Multiple on same worksheet

Participate now!

Share