sspatriots
Well-known Member
- Joined
- Nov 22, 2011
- Messages
- 585
- Office Version
- 365
- Platform
- Windows
Hi,
I have the worksheet change event code below that allows me to select any cell in my table column called "Description (Excluding Job List EQPT)" (Column I) and add as many items as I want from a drop-down list. The drop-down list is populated from a table on another worksheet called "Drops". That table name is called "tblDescription". As a user selects an item or items from the drop-down list, each one is added in the cell to the previous selection with a comma separating each selections. The problem I have is with the message box that pops up every time once you go to select the second item you want to add to the cell in that column. If each item I select (called "My_Value" and "My_HValue" in the code) is already in the drop-down list, I don't want that message box to appear. I only want it to appear if I am making an entry in that cell at any point that is something not found in that table that is referenced by the drop-down list, because that would be when I want the option to automatically add it to that table on the "Drops" worksheet. Basically, any entry that is not equal to the "My_Value" or "My_HValue" in the code should prompt that pop-up message box allowing me the option to add the item to the said table..
For example:
If my table on the "Drops" worksheet has the following entries in a single column table,
Red
Blue
Green
Yellow
Orange
Brown
If I were to select Red, Blue and Brown, the cell entry should look like "Red, Blue, Brown" and I should not get that pop-up message box. If I decided to make my first entry something that is not on the table, for instance "Purple" and then proceed to select Blue and Brown, I would like the message box to appear and ask if I want to add "Purple" to my drop-down list. Instead, as the code is written right now if I selected yes to the prompt, the entry "Purple, Blue, Brown" would be added to the table that the drop-down list references. Right now, my users just always have to keep selecting "No" every time they select additional items from the drop-down list.
Any assistance would be greatly appreciated.
I have the worksheet change event code below that allows me to select any cell in my table column called "Description (Excluding Job List EQPT)" (Column I) and add as many items as I want from a drop-down list. The drop-down list is populated from a table on another worksheet called "Drops". That table name is called "tblDescription". As a user selects an item or items from the drop-down list, each one is added in the cell to the previous selection with a comma separating each selections. The problem I have is with the message box that pops up every time once you go to select the second item you want to add to the cell in that column. If each item I select (called "My_Value" and "My_HValue" in the code) is already in the drop-down list, I don't want that message box to appear. I only want it to appear if I am making an entry in that cell at any point that is something not found in that table that is referenced by the drop-down list, because that would be when I want the option to automatically add it to that table on the "Drops" worksheet. Basically, any entry that is not equal to the "My_Value" or "My_HValue" in the code should prompt that pop-up message box allowing me the option to add the item to the said table..
For example:
If my table on the "Drops" worksheet has the following entries in a single column table,
Red
Blue
Green
Yellow
Orange
Brown
If I were to select Red, Blue and Brown, the cell entry should look like "Red, Blue, Brown" and I should not get that pop-up message box. If I decided to make my first entry something that is not on the table, for instance "Purple" and then proceed to select Blue and Brown, I would like the message box to appear and ask if I want to add "Purple" to my drop-down list. Instead, as the code is written right now if I selected yes to the prompt, the entry "Purple, Blue, Brown" would be added to the table that the drop-down list references. Right now, my users just always have to keep selecting "No" every time they select additional items from the drop-down list.
Any assistance would be greatly appreciated.
VBA Code:
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("I3:I3002")) 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
Exitsub:
Application.EnableEvents = True
If Target.Count > 1 Then Exit Sub
oldAddress = Target.Address
sSheetName = ActiveSheet.Name
R = ActiveCell.Row
'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 'Initial item selected
My_HValue = Target.Offset(2 - Target.Row).Value 'Subsequent item(s) selected
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
