多选项Data validation列表的VLOOKUP匹配实现需求咨询

问题描述 #

我现在有一段VBA代码，能实现单个数据验证列表里的多选功能（用|作为分隔符），现在需要实现的是：对下拉列表中选中的每一项，用VLOOKUP去Sheet2里查找对应的文本值并返回。

举个例子：如果我在下拉列表选中C0、XS 100、NCD这几个选项，希望能自动去Sheet2找到这三个项各自对应的文本内容，把结果展示出来。

现有多选功能VBA代码 #

这段代码负责实现C25单元格的多选下拉列表，分隔符是|：

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

已尝试的方法及问题 #

我自己试了一个公式：=VLOOKUP(C25,C26,C27,Sheet2!A1:B21,2,0)，但这个公式会返回溢出错误，而且从用户体验和美观度来说都很差，完全达不到需求。

我自己VBA经验不多，这段多选的代码也是找别人帮忙写的，现在想请教怎么实现选中多个选项后，自动匹配每个选项对应的文本并展示出来？

备注：内容来源于stack exchange，提问作者user22204457