Working with multiple Target Ranges in Worksheet Code

[sspatriots]

Hi,

I have the following worksheet code that I've pieced together over time, but now I'm stuck on one part. Everything seems to work fine except for the part of the code at the end in the section where I have it noted "CODE TO ENABLE ADDING ITEMS TO DROP-DOWN LIST STARTS HERE". The first part of this code allows me to continue selecting items from a drop-down list in column "J" and separates them with a comma. The second part is similar, except it puts each selected item on its on new line. The third part of this code is used to track changes to a worksheet on a separate worksheet called "LogDetails".

It's the last part of the code that I'm struggling with. This code basically gives the user an option to add anything they enter into a column that has a drop down-down list if it isn't already on that list. The problem I'm having is I want this part to exclude columns "J" and "M", because those are the two in the first two parts of my code that can consist of multiple list selections.

Any help would be much appreciated. Thank you, SS

Option Explicit
Dim Oldvalue As String
Dim Newvalue As String
Dim oldAddress As String

Private Sub Worksheet_Change(ByVal Target As Range)

Dim sSheetName As String
Dim R As Long
Dim cl As Range
Dim ws As Worksheet
Dim str As String
Dim i As Integer
Dim rngDV As Range
Dim rng As Range
Dim lCol As Long
Dim myRsp As Long
Dim My_Value As String
Dim My_HValue As String
Dim strList As String

On Error GoTo Exitsub
If Not Intersect(Target, Range("J:J")) Is Nothing Then
    If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
        GoTo Exitsub
        Else: If Target.Value = "" Then GoTo Exitsub Else
            Application.EnableEvents = False
            Newvalue = Target.Value
            Application.Undo
            Oldvalue = Target.Value
            If Oldvalue = "" Then
                Target.Value = Newvalue
            Else
            If InStr(1, Oldvalue, Newvalue) = 0 Then
                Target.Value = Oldvalue & ", " & Newvalue
            Else:
                Target.Value = Oldvalue
            End If
        End If
    End If
End If

Application.EnableEvents = True

On Error GoTo Exitsub
If Not Intersect(Target, Range("M:M")) Is Nothing Then
    If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
        GoTo Exitsub
        Else: If Target.Value = "" Then GoTo Exitsub Else
            Application.EnableEvents = False
            Newvalue = Target.Value
            Application.Undo
            Oldvalue = Target.Value
            If Oldvalue = "" Then
                Target.Value = Newvalue
            Else
            If InStr(1, Oldvalue, Newvalue) = 0 Then
                Target.Value = Oldvalue & vbNewLine & Newvalue
            Else:
                Target.Value = Oldvalue
            End If
        End If
    End If
End If

Application.EnableEvents = True

Exitsub:
    
Application.EnableEvents = True

If Target.Count > 1 Then Exit Sub
If Intersect(Target, Range("E:E,G:J,M:Q")) Is Nothing Then Exit Sub

oldAddress = Target.Address

sSheetName = ActiveSheet.Name
R = ActiveCell.Row

If ActiveSheet.Name <> "LogDetails" Then

    Application.EnableEvents = False

    'THIS CODE POPULATES Columns A through E on the "LogDetails" worksheet
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = ActiveSheet.Name & " - " & Target.Address(0, 0)
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 1).Value = Oldvalue
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 2).Value = Target.Value
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 3).Value = Environ("username")
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 4).Value = Now

    'THIS CODE POPULATES THE CELLS THAT GET SENT OUT WHEN HILLARY SENDS OUT ALL THE PO BLOCK HISTORY UPDATES
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 6).Value = ActiveSheet.Range("A" & R)  'PO# column G on LogDetails tab
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 7).Value = ActiveSheet.Range("E" & R)  'Supplier column H on LogDetails tab
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 8).Value = ActiveSheet.Range("G" & R)  'By column I on LogDetails tab
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 9).Value = ActiveSheet.Range("H" & R)  'Ship to column J on LogDetails tab
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 10).Value = ActiveSheet.Range("I" & R) 'Description(Excluding Job List EQPT) column K on LogDetails tab
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 11).Value = ActiveSheet.Range("J" & R) 'Job List Equipment column L on LogDetails tab
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 12).Value = ActiveSheet.Range("M" & R) 'DEM Job Name2 column M on LogDetails tab
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 13).Value = ActiveSheet.Range("O" & R) 'DEM Customer column N on LogDetails tab
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 14).Value = ActiveSheet.Range("P" & R) 'Notes: column O on LogDetails tab
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 15).Value = ActiveSheet.Range("Q" & R) 'Date Received: column P on LogDetails tab

    'ADD THE BACK LINK
    Sheets("LogDetails").Hyperlinks.Add Anchor:=Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 5), Address:="", _
    SubAddress:="'" & sSheetName & "'!" & oldAddress, TextToDisplay:=oldAddress

    Sheets("LogDetails").Columns("A:E").AutoFit

    Application.EnableEvents = True

End If

'CODE TO ENABLE ADDING ITEMS TO DROP-DOWN LIST STARTS HERE
On Error Resume Next

Set ws = Worksheets("Drops")

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

    My_Value = Target.Value

    My_HValue = Target.Offset(2 - Target.Row).Value

    myRsp = MsgBox("Add '" & My_Value & "' to the '" & My_HValue & "' drop down list?", _
        vbQuestion + vbYesNo + vbDefaultButton1, _
        "New Item -- not in drop down")

    If myRsp = vbYes Then
        lCol = rng.Column
        i = ws.Cells(Rows.Count, lCol).End(xlUp).Row + 1
        ws.Cells(i, lCol).Value = Target.Value

        strList = ws.Cells(1, lCol).ListObject.Name

        With ws.ListObjects(strList).Sort
            .SortFields.Clear
            .SortFields.Add _
                Key:=Cells(2, lCol), _
                SortOn:=xlSortOnValues, _
                Order:=xlAscending
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

        With ws.ListObjects(strList)
            .Resize .DataBodyRange.CurrentRegion
        End With

    End If

End If

End If
'CODE TO ENABLE ADDING ITEMS TO DROP-DOWN LIST STOPS HERE

End Sub

 

[kevin9999]

I take it this worksheet event code is not in the "LogDetails" sheet module, therefore the following line is probably redundant:

If ActiveSheet.Name <> "LogDetails" Then

Try replacing that line with this:

If Target.Column <> 10 And Target.Column <> 13 Then

 

[RoryA]

If you want to exclude J and M, don't include them in this line:

If Intersect(Target, Range("E:E,G:J,M:Q")) Is Nothing Then Exit Sub

Change it to:

If Intersect(Target, Range("E:E,G:I,N:Q")) Is Nothing Then Exit Sub

 

[sspatriots]

Thanks for the ideas. I tried them both but still had an issue with either the third part of the code working and the 4th part not working or just the opposite would happen. However, it got me to thinking a bit about your suggestions. So I commented out this line in the code altogether, because it turned out that the third section would work just fine without it:

If Target.Count > 1 Then Exit Sub
'If Intersect(Target, Range("E:E,G:J,M:Q")) Is Nothing Then Exit Sub

From RoryA's suggestion, I took that line and moved it down to the fourth part of my code to make it only exclude the columns I don't want as shown below:

Set ws = Worksheets("Drops")

If Not Intersect(Target, Range("J:J,M:M")) Is Nothing Then Exit Sub

If Target.Row > 1 Then
    On Error Resume Next

I love the ideas I get from this group. They have always been the best support system for anyone like myself who only knows enough to piece different bits of everyone's inputs together. Thanks again for all the ideas and help.


Regards, SS