Question

我在trumpexcel.com使用了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

Answer 1

您需要做的就是完全按原样保留代码并将其放在工作表中，并进行以下修改：

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

功能在此处找到：Matching values in string array

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

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

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

1 个答案: