Help making my VBA code apply to only one column

[Melvetica]

Hi, I found this code that makes a drop down list eligible for multiple selections, and I want that to only apply to column D in my sheet. I added this line "If Not Intersect(Destination, Range("D:D")) Is Nothing Then" to hopefully get it to only apply to that column, but no dice. Any suggestions?

Private Sub Worksheet_Change(ByVal Destination As Range)
Dim rngDropdown As Range
Dim oldValue As String
Dim newValue As String
Dim DelimiterType As String
DelimiterType = ", "
Dim DelimiterCount As Integer
Dim TargetType As Integer
Dim i As Integer
Dim arr() As String
 
If Destination.Count > 1 Then Exit Sub
On Error Resume Next
 
Set rngDropdown = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitError
 
If rngDropdown Is Nothing Then GoTo exitError

If Not Intersect(Destination, Range("D:D")) Is Nothing Then
    TargetType = 0
        TargetType = Destination.Validation.Type
        If TargetType = 3 Then  ' is validation type is "list"
            Application.ScreenUpdating = False
            Application.EnableEvents = False
            newValue = Destination.Value
            Application.Undo
            oldValue = Destination.Value
            Destination.Value = newValue
            If oldValue <> "" Then
                If newValue <> "" Then
                    If oldValue = newValue Or oldValue = newValue & Replace(DelimiterType, " ", "") Or oldValue = newValue & DelimiterType Then ' leave the value if there is only one in the list
                        oldValue = Replace(oldValue, DelimiterType, "")
                        oldValue = Replace(oldValue, Replace(DelimiterType, " ", ""), "")
                        Destination.Value = oldValue
                    ElseIf InStr(1, oldValue, DelimiterType & newValue) Or InStr(1, oldValue, newValue & DelimiterType) Or InStr(1, oldValue, DelimiterType & newValue & DelimiterType) Then
                        arr = Split(oldValue, DelimiterType)
                    If Not IsError(Application.Match(newValue, arr, 0)) = 0 Then
                        Destination.Value = oldValue & DelimiterType & newValue
                            Else:
                        Destination.Value = ""
                        For i = 0 To UBound(arr)
                        If arr(i) <> newValue Then
                            Destination.Value = Destination.Value & arr(i) & DelimiterType
                        End If
                        Next i
                    Destination.Value = Left(Destination.Value, Len(Destination.Value) - Len(DelimiterType))
                    End If
                    ElseIf InStr(1, oldValue, newValue & Replace(DelimiterType, " ", "")) Then
                        oldValue = Replace(oldValue, newValue, "")
                        Destination.Value = oldValue
                    Else
                        Destination.Value = oldValue & DelimiterType & newValue
                    End If
                    Destination.Value = Replace(Destination.Value, Replace(DelimiterType, " ", "") & Replace(DelimiterType, " ", ""), Replace(DelimiterType, " ", "")) ' remove extra commas and spaces
                    Destination.Value = Replace(Destination.Value, DelimiterType & Replace(DelimiterType, " ", ""), Replace(DelimiterType, " ", ""))
                    If Destination.Value <> "" Then
                        If Right(Destination.Value, 2) = DelimiterType Then  ' remove delimiter at the end
                            Destination.Value = Left(Destination.Value, Len(Destination.Value) - 2)
                        End If
                    End If
                    If InStr(1, Destination.Value, DelimiterType) = 1 Then ' remove delimiter as first characters
                        Destination.Value = Replace(Destination.Value, DelimiterType, "", 1, 1)
                    End If
                    If InStr(1, Destination.Value, Replace(DelimiterType, " ", "")) = 1 Then
                        Destination.Value = Replace(Destination.Value, Replace(DelimiterType, " ", ""), "", 1, 1)
                    End If
                    DelimiterCount = 0
                    For i = 1 To Len(Destination.Value)
                        If InStr(i, Destination.Value, Replace(DelimiterType, " ", "")) Then
                            DelimiterCount = DelimiterCount + 1
                        End If
                    Next i
                    If DelimiterCount = 1 Then ' remove delimiter if last character
                        Destination.Value = Replace(Destination.Value, DelimiterType, "")
                        Destination.Value = Replace(Destination.Value, Replace(DelimiterType, " ", ""), "")
                    End If
                End If
            End If
            Application.EnableEvents = True
            Application.ScreenUpdating = True
        End If
    End If
 
exitError:
  Application.EnableEvents = True
End Sub

 

[kevin9999]

Try this:

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

 

[Alex Blakenburg]

I don't believe @kevin9999 suggestion will work for you. You don't see it done often but your code replaces the commonly used default of "Target" with "Destination"
I have also tracked down the source of your code to AbleBits.

What is your code doing that makes you say it is not working ?
At the moment if the cell you changed does not have any Data Validation the code will error out and Exit at this point.
TargetType = Destination.Validation.Type
It will only make it to that point if the changed cell is in Column D as per the intersect condition, otherwise it will bypass all the working code.
You could change this line to only look at Column D
Set rngDropdown = Columns("D").SpecialCells(xlCellTypeAllValidation)
but that would just mean it would only error out there and exit if there was no validation in Column D and I am assuming there is at least some validation in Column D.

So do you have validation on the cell(s) in column D you are changing and what if the code doing or not doing and what do you expect it to do ?
(pictures would be helpful)


Code ref: In the URL below under the heading "Multi-selection dropdown with item removal"

How to create multi-select drop down list in Excel

Discover how to create an Excel drop down to select multiple items. Depending on your needs, it can be with or without duplicates and allow for item removal.

www.ablebits.com