I have the below code, which allows for the multiple selection of items within a single data validation list, what I need is a vlookup that can find each item in the drop down list and return the corresponding values.
For example, I have all the data being used for the vlookup on sheet 2, when I select from the drop down list C0, XS 100, NCD - I want the vlookup to go to sheet 2, find C0, XS 100 & NCD and return the values for each item (the return values is text that the user needs to read)
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("C25")) 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) 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
If Not Intersect(Destination, Range("C7")) Is Nothing Then
Select Case Destination
Case Is = "Solutions"
MsgBox "YOU HAVE SELECTED: SOLUTIONS POLICY - NO NCD CHECK REQUIRED"
Case Is = "H/Sol"
MsgBox "YOU HAVE SELECTED HEALTHIER SOLUTIONS POLICY - CHECK THE NCD IN UNO AND ACPM"
End Select
End If
If Not Intersect(Destination, Range("G7")) Is Nothing Then
Select Case Destination
Case Is = "NMORI"
MsgBox "NMORI - FULL HISTORY TO BE TAKEN - USE STEP 2 TO HELP YOU DETERMINE IF THE SYMPTOMS ARE PRE-EXISTING"
Case Is = "CMORI"
MsgBox "CMORI - FULL HISTORY TO BE TAKEN - USE STEP 2 TO HELP YOU DETERMINE IF THE SYMPTOMS ARE PRE-EXISTING"
Case Is = "CME"
MsgBox "CME - CHECK IF THE SYMPTOMS ARE RELATED TO ANY EXCLUSIONS IF NOT RELATED TREAT AS MHD"
Case Is = "FMU"
MsgBox "FMU - CHECK HISTORY, CHECK IF SYMPTOMS ARE RELATED TO ANY EXCLUSIONS & CHECK IF THE SYMPTOMS REPORTED SHOULD HAVE BEEN DELCARED TO US"
Case Is = "MHD"
MsgBox "MHD - TAKE BRIEF HISTORY ONLY"
End Select
End If
exitError:
Application.EnableEvents = True
End Sub
As I'm not massively VBA experienced and have essentially relied upon others for help. The only thing I have tried is a this =Vlookup(C25, C26, C27,Sheet2!A1:B21,2,0) but this returns a spill error and doesn't really work well from a user view and also isn't asesthetically pleasing
This code is handling multiple drop-downs and combining lookups into a single textbox
Try this out:
Option Explicit
Const DELIM As String = " | "
Private Sub Worksheet_Change(ByVal Target As Range)
Dim oldValue As String, newValue As String, sep As String
Dim arr() As String, s As String, el, remove As Boolean, allDDVals As String
If Target.CountLarge > 1 Then Exit Sub
newValue = Target.Value
On Error GoTo exitError
Select Case Target.Address(False, False)
Case "C25", "C26", "C27", "C28" '<<< 4 potential drop-downs
If Not HasListValidation(Target) Then Exit Sub
If Len(newValue) > 0 Then 'check cell was not cleared
Application.EnableEvents = False
Application.Undo
oldValue = Target.Value
If Len(oldValue) > 0 Then
arr = Split(oldValue, DELIM)
For Each el In arr
If el = newValue Then
remove = True 'remove if re-selected
Else
s = s & sep & el 'else add to cell content
sep = DELIM
End If
Next el
If Not remove Then s = s & sep & newValue 'add if not a re-selection
Target.Value = s
Else
Target.Value = newValue
End If
End If
allDDVals = MultiLookup(Me.Range("C25").Value, Me.Range("C26").Value, _
Me.Range("C27").Value, Me.Range("C28").Value)
Me.Range("D25").Value = allDDVals 'perform the lookups and populate (eg) to the next cell
Me.OLEObjects("Textbox1").Object.Value = allDDVals 'or add to textbox
Case "C7"
Select Case newValue
Case "Solutions"
MsgBox "YOU HAVE SELECTED: SOLUTIONS POLICY - NO NCD CHECK REQUIRED"
Case "H/Sol"
MsgBox "YOU HAVE SELECTED HEALTHIER SOLUTIONS POLICY - CHECK THE NCD IN UNO AND ACPM"
End Select 'C7 values
Case "G7"
Select Case newValue
Case "NMORI", "CMORI"
MsgBox newValue & " - FULL HISTORY TO BE TAKEN - USE STEP 2 TO HELP" & _
" YOU DETERMINE IF THE SYMPTOMS ARE PRE-EXISTING"
Case "CMORI"
MsgBox "CMORI - FULL HISTORY TO BE TAKEN - USE STEP 2 TO HELP YOU " & _
"DETERMINE IF THE SYMPTOMS ARE PRE-EXISTING"
Case "CME"
MsgBox "CME - CHECK IF THE SYMPTOMS ARE RELATED TO ANY EXCLUSIONS" & _
" IF NOT RELATED TREAT AS MHD"
Case "FMU"
MsgBox "FMU - CHECK HISTORY, CHECK IF SYMPTOMS ARE RELATED TO ANY EXCLUSIONS " & _
" CHECK IF THE SYMPTOMS REPORTED SHOULD HAVE BEEN DELCARED TO US"
Case "MHD"
MsgBox "MHD - TAKE BRIEF HISTORY ONLY"
End Select 'G7 values
Case Else
Exit Sub
End Select 'Target address
exitError:
Application.EnableEvents = True
End Sub
'Given input `txt` containing zero or more DELIM-separated values,
' perform a lookup on each value, and return all of the results in
' a single string
' Returns "?value?" for any term not matched in the vlookup
Function MultiLookup(ParamArray texts() As Variant)
Dim arr, el, s As String, res, sep As String, i As Long, txt As String
For i = LBound(texts) To UBound(texts)
txt = texts(i)
If Len(txt) > 0 Then
arr = Split(txt, DELIM)
For Each el In arr
res = Application.VLookup(el, ThisWorkbook.Sheets("Sheet2").Range("A1:B21"), 2, False)
If IsError(res) Then res = "?" & el & "?"
s = s & sep & res
sep = vbLf '## use different delimiter for the output
Next el
End If
Next i
MultiLookup = s
End Function
'does a cell have list validation applied?
Public Function HasListValidation(c As Range) As Boolean
On Error Resume Next 'ignore error if no validation on cell
HasListValidation = (c.Validation.Type = 3)
End Function