VBA – 从下拉列表中select多个项目
我在trumpexcel.com上使用了Sumit Bansal的代码，但是代码似乎不起作用。 它应该从下拉列表中select多个文本而不重复。 下拉是单元格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
函数在这里find： 匹配string数组中的值
这将允许您从引用的十个单元格的下拉列表中select多个项目。
值得注意的是，这段代码使用了撤消function，所以任何时候你用它来select多个项目，你都将失去在这之前撤销任何东西的能力。