Apply macro to specific columns only

lammatt145

New Member
Joined
Aug 12, 2022
Messages
2
Office Version
  1. 2016
Platform
  1. Windows
Hello,

I am a novice excel user and I have used a pre-built macro to allow me to select multiple options from a list. The macro also allows me to remove selected entries by re-selecting them from the list. I only want this macro applied to specific columns - in this case columns C - K inclusive. Could someone help me edit my macro to do this?

Here's my macro:

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 2019/11/13
'Updated by Ken Gardner 2022/07/11
Dim xRng As Range
Dim xValue1 As String
Dim xValue2 As String
Dim semiColonCnt As Integer
If Target.Count > 1 Then Exit Sub
On Error Resume Next
Set xRng = Cells.SpecialCells(xlCellTypeAllValidation)
If xRng Is Nothing Then Exit Sub
Application.EnableEvents = False
'If Not Application.Intersect(Target, xRng) Is Nothing Then
If Application.Intersect(Target, xRng) Then
xValue2 = Target.Value
Application.Undo
xValue1 = Target.Value
Target.Value = xValue2
If xValue1 <> "" Then
If xValue2 <> "" Then
If xValue1 = xValue2 Or xValue1 = xValue2 & ";" Or xValue1 = xValue2 & "; " Then ' leave the value if only one in list
xValue1 = Replace(xValue1, "; ", "")
xValue1 = Replace(xValue1, ";", "")
Target.Value = xValue1
ElseIf InStr(1, xValue1, "; " & xValue2) Then
xValue1 = Replace(xValue1, xValue2, "") ' removes existing value from the list on repeat selection
Target.Value = xValue1
ElseIf InStr(1, xValue1, xValue2 & ";") Then
xValue1 = Replace(xValue1, xValue2, "")
Target.Value = xValue1
Else
Target.Value = xValue1 & "; " & xValue2
End If
Target.Value = Replace(Target.Value, ";;", ";")
Target.Value = Replace(Target.Value, "; ;", ";")
If InStr(1, Target.Value, "; ") = 1 Then ' check for ; as first character and remove it
Target.Value = Replace(Target.Value, "; ", "", 1, 1)
End If
If InStr(1, Target.Value, ";") = 1 Then
Target.Value = Replace(Target.Value, ";", "", 1, 1)
End If
semiColonCnt = 0
For i = 1 To Len(Target.Value)
If InStr(i, Target.Value, ";") Then
semiColonCnt = semiColonCnt + 1
End If
Next i
If semiColonCnt = 1 Then ' remove ; if last character
Target.Value = Replace(Target.Value, "; ", "")
Target.Value = Replace(Target.Value, ";", "")
End If
End If
End If
End If
Application.EnableEvents = True
End Sub



Thank you!
 

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!
Not run it but try

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 2019/11/13
'Updated by Ken Gardner 2022/07/11
'Update by Nemmi 2022/08/12 column range
Dim xRng As Range
Dim xValue1 As String
Dim xValue2 As String
Dim semiColonCnt As Integer
If Target.Count > 1 Then Exit Sub
On Error Resume Next
Set xRng = Cells.SpecialCells(xlCellTypeAllValidation)
If xRng Is Nothing Then Exit Sub
If Target.Column >= 3 And Target.Column <= 11 Then 'C - K
    Application.EnableEvents = False
    'If Not Application.Intersect(Target, xRng) Is Nothing Then
    If Application.Intersect(Target, xRng) Then
    xValue2 = Target.Value
    Application.Undo
    xValue1 = Target.Value
    Target.Value = xValue2
    If xValue1 <> "" Then
    If xValue2 <> "" Then
    If xValue1 = xValue2 Or xValue1 = xValue2 & ";" Or xValue1 = xValue2 & "; " Then ' leave the value if only one in list
    xValue1 = Replace(xValue1, "; ", "")
    xValue1 = Replace(xValue1, ";", "")
    Target.Value = xValue1
    ElseIf InStr(1, xValue1, "; " & xValue2) Then
    xValue1 = Replace(xValue1, xValue2, "") ' removes existing value from the list on repeat selection
    Target.Value = xValue1
    ElseIf InStr(1, xValue1, xValue2 & ";") Then
    xValue1 = Replace(xValue1, xValue2, "")
    Target.Value = xValue1
    Else
    Target.Value = xValue1 & "; " & xValue2
    End If
    Target.Value = Replace(Target.Value, ";;", ";")
    Target.Value = Replace(Target.Value, "; ;", ";")
    If InStr(1, Target.Value, "; ") = 1 Then ' check for ; as first character and remove it
    Target.Value = Replace(Target.Value, "; ", "", 1, 1)
    End If
    If InStr(1, Target.Value, ";") = 1 Then
    Target.Value = Replace(Target.Value, ";", "", 1, 1)
    End If
    semiColonCnt = 0
    For i = 1 To Len(Target.Value)
    If InStr(i, Target.Value, ";") Then
    semiColonCnt = semiColonCnt + 1
    End If
    Next i
    If semiColonCnt = 1 Then ' remove ; if last character
    Target.Value = Replace(Target.Value, "; ", "")
    Target.Value = Replace(Target.Value, ";", "")
    End If
    End If
    End If
    End If
End If
Application.EnableEvents = True
End Sub
 
Upvote 0
Solution

Forum statistics

Threads
1,223,228
Messages
6,170,871
Members
452,363
Latest member
merico17

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