Closed. This question needs to be more focused. It is not currently accepting answers.
Want to improve this question? Update the question so it focuses on one problem only by editing this post.
Closed 8 years ago.
Improve this question
I am trying to select multiple values in excel from two different drop down lists. I have code that can select multiple values on one drop down and would like to be able to do the same for another drop down list with different values. Can I use the code below and modify it or is there another easier way to do this?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
If Target.Count > 1 Then GoTo exitHandler
On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler
If rngDV Is Nothing Then GoTo exitHandler
If Intersect(Target, rngDV) Is Nothing Then
'do nothing
Else
Application.EnableEvents = False
newVal = Target.Value
Application.Undo
oldVal = Target.Value
Target.Value = newVal
If Target.Column = 7 Or Target.Column = 45 Then
If oldVal = "" Then
'do nothing
Else
If newVal = "" Then
'do nothing
Else
Target.Value = oldVal _
& ", " & newVal
End If
End If
End If
End If
exitHandler:
Application.EnableEvents = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
If Target.Count > 1 Then GoTo exitHandler
On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler
If rngDV Is Nothing Then GoTo exitHandler
If Intersect(Target, rngDV) Is Nothing Then
'do nothing
Else
Application.EnableEvents = False
newVal = Target.Value
Application.Undo
oldVal = Target.Value
Target.Value = newVal
If Target.Column = 7 Or Target.Column = 45 Then
If oldVal = "" Then
'do nothing
Else
If newVal = "" Then
'do nothing
Else
Target.Value = oldVal _
& ", " & newVal
End If
End If
End If
End If
exitHandler: Application.EnableEvents = True End Sub
I used a conditional Or to make it possible to select multiple values from two different drop down lists. This is shown in the code If Target.Column = 7 Or Target.Column = 45 Then
Related
I have set up a spreadsheet with several columns, some of which have data validation dropdown lists. I need users to be able to select multiple options from the dropdown list. I have achieved this for one column using the VBA below, however I am struggling to find the right way to apply this to multiple columns. Please could someone help.
At the moment I have used 'Target.Column = 9', however I need to apply this to columns 3,4,5,6,9.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Oldvalue As String
Dim Newvalue As String
Application.EnableEvents = True
On Error GoTo Exitsub
If Target.Column = 9 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
End Sub
Thanks in advance
You could extend your If
If Target.Column = 9 or Target.Column = 3 etc
but sometimes Select Case is a bit tidier.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Oldvalue As String
Dim Newvalue As String
Application.EnableEvents = True
On Error GoTo Exitsub
Select Case Target.Column
Case 3, 4, 5, 6, 9
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 Select
Exitsub:
Application.EnableEvents = True
End Sub
I have a couple of lists within an excel spreadsheet that I would like to add the multi-select option to. I am well aware of how to do this thanks to contexture:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
If Target.Count > 1 Then GoTo exitHandler
On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler
If rngDV Is Nothing Then GoTo exitHandler
If Intersect(Target, rngDV) Is Nothing Then
'do nothing
Else
Application.EnableEvents = False
newVal = Target.Value
Application.Undo
oldVal = Target.Value
Target.Value = newVal
If Target.Column = 3 Then
If oldVal = "" Then
'do nothing
Else
If newVal = "" Then
'do nothing
Else
Target.Value = oldVal _
& ", " & newVal
' NOTE: you can use a line break,
' instead of a comma
' Target.Value = oldVal _
' & Chr(10) & newVal
End If
End If
End If
End If
exitHandler:
Application.EnableEvents = True
End Sub
The problem is that I only want particular lists to be multi-select, i have a couple of other lists within this excel spreadsheet that must remain as one option lists. This code works but it affects every list within excel. I attempted to modify it to work on only certain Cells by adding an if statement like below
If Target.Address = "$C$5" Or Target.Address = "$C$6" Or Target.Address = "$C$82" Then
This still is not working for me, how can I make this code cell specific?
For anyone else who stumbles upon this in hopes of finding an answer on how to make a specific list have the multi-select option I was able to figure it out on my own.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim strVal As String
Dim i As Long
Dim lCount As Long
Dim Ar As Variant
On Error Resume Next
Dim lType As Long
If Target.Count > 1 Then GoTo ExitHandler
lType = Target.Validation.Type
If lType = 3 Then
Application.EnableEvents = False
newVal = Target.Value
Application.Undo
If Target.Value = "Select all that apply" Then
oldVal = ""
Else
If Target.Value = newVal Then
newVal = "Select all that apply"
Else
oldVal = Target.Value
End If
End If
'oldVal = Target.Value
Target.Value = newVal
'This is where specific cells will be referenced
If Target.Address = "$F$8" Or Target.Address = "$G$6" Or Target.Address = "$H$3" Or Target.Address = "$CJ$29" Then
If oldVal = "" Then
Else
If newVal = "" Then
Else
On Error Resume Next
Ar = Split(oldVal, ", ")
strVal = ""
For i = LBound(Ar) To UBound(Ar)
Debug.Print strVal
Debug.Print CStr(Ar(i))
If newVal = CStr(Ar(i)) Then
strVal = strVal
lCount = 1
Else
strVal = strVal & CStr(Ar(i)) & ", "
End If
Next i
If lCount > 0 Then
Target.Value = Left(strVal, Len(strVal) - 2)
Else
Target.Value = strVal & newVal
End If
End If
End If
End If
End If
In order to use this specific solution you will also need to add
ExitHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
To the very end of your code.
I utilized the code by Sumit Bansal at trumpexcel.com, however, the code doesn't seem to work. It is supposed to select more than one of the texts from the drop down without repetition. The drop down is for cells C8, C22, C36, until C134. Here is the code, thanks in advance.
Option Explicit
Private Sub DropDown(ByVal Target As Range)
'Code by Sumit Bansal from https://trumpexcel.com
' To Select Multiple Items from a Drop Down List in Excel
Dim Oldvalue As String
Dim Newvalue As String
Dim x As Double
Application.EnableEvents = True
On Error GoTo Exitsub
For x = 1 To 10
If Target.Address = Worksheets("BSOAP").Range("C" & (14 * x - 6)) 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
Next x
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True
End Sub
All you need to do is leave the code exactly as it was given and place it in your worksheet, with the following modifications:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
'Code by Sumit Bansal from https://trumpexcel.com
'Modified by TheEngineer from https://stackoverflow.com/
' To Select Multiple Items from a Drop Down List in Excel
Dim Oldvalue As String
Dim Newvalue As String
Dim i As Long
Dim b As Boolean
Dim arr(1 To 10) As String
For i = 1 To 10
arr(i) = "$C$" & (14 * i - 6)
Next i
On Error GoTo Exitsub
If Contains(arr, Target.Address) 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
Target.Value = Oldvalue & ", " & Newvalue
End If
End If
End If
Exitsub:
Application.EnableEvents = True
End Sub
Function Contains(arr, v) As Boolean
Dim rv As Boolean, lb As Long, ub As Long, i As Long
lb = LBound(arr)
ub = UBound(arr)
For i = lb To ub
If arr(i) = v Then
rv = True
Exit For
End If
Next i
Contains = rv
End Function
The Function was found here: Matching values in string array
This will allow you to select multiple items from the dropdown lists in the ten cells you referenced.
It is worth noting that this code uses the Undo function, so any time you use it to select multiple items, you will lose your ability to Undo anything before that point.
Could someone please help me with the below VBA code. Instead of displaying the results in different rows of the same cell, I want to display in different rows of the same column.
Your help would be very much appreciated!!!
Private Sub Worksheet_Change(ByVal Target As Range)
**' To Select Multiple Items from a Drop Down List in Excel and display the
' result in different rows for further calculations.**
Dim Oldvalue As String
Dim Newvalue As String
Application.EnableEvents = True
On Error GoTo Exitsub
If Target.Column = 8 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 & Chr(10) & Newvalue***
Else:
Target.Value = Oldvalue
End If
End If
End If
End If
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True
End Sub
This sub passes the old value a cell below the range that triggered the sub. And passes the new value 2 cells below that same range.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Oldvalue As String '<~ declare old value
Dim Newvalue As String '<~ declare new value
Application.EnableEvents = True '<~enable events( idunno why)
On Error GoTo ExitSub '<~ simple error handler
If Not Target.Column = 8 Then GoTo ExitSub '<~ if the change not happened in col8 then exit
If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then GoTo ExitSub
If Target.Value = "" Then GoTo ExitSub '<~ if the new value is blank then exit
Application.EnableEvents = False '<~ disableevents
Newvalue = Target.Value '<~ pass new value into a variable
Application.Undo '<~ force undo
Oldvalue = Target.Value '<~ pass previous value into a variable
Target.Value = Newvalue '<~ give new value
If Not Oldvalue = "" Then '<~ check if old value is blank
If InStr(1, Oldvalue, Newvalue) = 0 Then '<~ check if the old value
Target.Offset(1, 0).Value = "Old Value: " & Oldvalue '<~ pass old value to a cell below the
Target.Offset(2, 0).Value = "New Value: " & Newvalue '<~ range that made a change
End If
End If
ExitSub:
Application.EnableEvents = True
End Sub
I want to combine these two lines of code but cannot figure out how to get it to work. They both work separately, but I want the first line of code to be the first operation and then the second sub to be the second operation. These should execute whenever there is a change to the worksheet. The first routine should only cause a msg box when the corresponding cell in the "S" range updates in the same row as the cell that was updated in column A or B.
The second operation should look for any change in range "T7:T26" and prompt a msg box.
Code is below:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myRng As Range
Dim lRow As Long
If Target.CountLarge > 1 Then Exit Sub
On Error GoTo Whoa
Set myRng = Range("A7:B26")
Application.EnableEvents = False
If Not Intersect(Target, myRng) Is Nothing Then
lRow = Target.Row
If Range("S" & lRow).Value >= 16 Then sVar = _
MsgBox("Will Enough Pre-Wave Resources be Available?", 4, "Attention!")
If sVar = 7 Then Application.Undo
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
and
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myRng As Range
Set myRng = ThisWorkbook.Sheets("SMT 5").Range("T7:T26")
For Each mycell In myRng
If mycell.Value = "ISSUE" Then sVar = MsgBox("Possible Pre-Wave Manpower Issue on 2nd or 3rd Shift. Will Enough Resources be Available?", 4, "Attention!")
If sVar = 7 Then
Application.Undo
End If
Exit For
Next
End Sub
If both of them work on their own, you can copy the code into a module and give them two distinct names.
Then, in the Worksheet_Change sub you just use Call to run both subs.
Is this what you are trying?
Const sMsg1 As String = "Will Enough Pre-Wave Resources be Available?"
Const sMsg2 As String = "Possible Pre-Wave Manpower Issue on " & _
"2nd or 3rd Shift. Will Enough Resources be Available?"
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myRng As Range, othrRng As Range, aCell As Range
Dim lRow As Long
Dim sVar
If Target.CountLarge > 1 Then Exit Sub
On Error GoTo Whoa
Set myRng = Range("A7:A26")
Set othrRng = Range("T7:T26")
Application.EnableEvents = False
If Not Intersect(Target, myRng) Is Nothing Then
lRow = Target.Row
If Range("S" & lRow).Value >= 16 Then sVar = _
MsgBox(sMsg1, 4, "Attention!")
If sVar = 7 Then Application.Undo
End If
For Each aCell In othrRng
If aCell.Value = "ISSUE" Then _
sVar = MsgBox(sMsg2, 4, "Attention!")
If sVar = 7 Then
Application.Undo
Exit For
End If
Next
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myRng As Range
Dim lRow As Long
If Target.CountLarge > 1 Then Exit Sub
On Error GoTo Whoa
Set myRng = Range("A7:B26")
Application.EnableEvents = False
If Not Intersect(Target, myRng) Is Nothing Then
lRow = Target.Row
If Range("S" & lRow).Value >= 16 Then sVar = _
MsgBox("Will Enough Pre-Wave Resources be Available?", 4, "Attention!")
If sVar = 7 Then Application.Undo
End If
Set othrRng = Range("T7:T26")
For Each aCell In othrRng
If aCell.Value = "ISSUE" Then sVar = MsgBox("Possible Pre-Wave Manpower Issue on 2nd or 3rd Shift. Will Enough Resources be Available?", 4, "Attention!")
If sVar = 7 Then
Application.Undo
Exit For
End If
Next
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub