VBA-从下拉列表中选择多个项目

我使用了Sumit Bansal的代码，但是，代码似乎不起作用。它应该从下拉列表中选择多个文本而不重复。下拉列表适用于单元格C8、C22、C36，直至C134。这是代码，提前谢谢

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

---

您只需将代码保持原样，并将其放入工作表中，然后进行以下修改：

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

该函数可在此处找到：

这将允许您从引用的十个单元格中的下拉列表中选择多个项目

---

值得注意的是，这段代码使用了撤销功能，因此，每当您使用它选择多个项目时，您将失去在此之前撤销任何内容的能力。

到底是什么问题？是否存在特定错误？如果是，在哪一行上，有什么错误消息？还是仅仅是意外的行为？需要更多的信息。@Zerk，它只是没有从列表中选择多个。鉴于潜艇取决于目标范围，而您没有告诉我们您提供的范围是我们猜测的来源。你怎么称呼潜艇？你提供了什么？@Zerk，很抱歉，我不完全理解你的问题。我对VBA非常陌生，而创建者没有完全解释这段代码的逻辑。除了被任意命名为Dropdown外，sub没有明确地做任何与下拉框相关的事情。如果看不到它是如何使用的，它与什么一起使用，以及你想要它做什么的确切意图，那么就不可能有帮助。我为没有回应而道歉。我误解了我的主管想要的，他不想要这个，而是清单上的一个项目，上面写着所有项目。我再次道歉，不用担心。我很高兴你能解决你的问题。如果此答案满足所问问题的要求，请将其标记为正确答案。