如何使用VBA从Excel中的列表框中获取基于多项选择的结果？

Question

我想要完成的是：

当我在单元格 D2 中选择多种类型的折扣时（注意：单元格 D2 有一个宏，允许我从下拉列表中选择多种选择，并用逗号分隔这两种选择），我想获得它们在单元格 E2 中的相应值。在这种情况下，由于我选择了“学生”和“退伍军人”，因此我在单元格 E2 中得到 0.5 的倍数和 0.03 = 0.15。

因为我有多种折扣类型，所以简单的 if 语句是行不通的，因为我可能会以任何顺序一次选择两个以上的折扣。请帮忙，因为我对 VBA 很陌生。谢谢！

这是我用于从下拉列表框中进行多项选择的代码。注意：此代码是我从网上复制的。

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Oldvalue As String
  Dim Newvalue As String

  Application.EnableEvents = True

  On Error GoTo Exitsub

  If Not Intersect(Target, Columns(4)) Is Nothing 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

Application.EnableEvents = True

Exitsub:

Application.EnableEvents = True

End Sub

Answer 1

如果您有 Excel 365，则可以使用公式、使用

FILTERXML

和溢出范围轻松完成此操作

=PRODUCT(XLOOKUP(FILTERXML("<a><s>"&SUBSTITUTE(E2,",","</s><s>")&"</s></a>","//s"),A:A,B:B,0,0))

---

或者，UDF（不需要 Excel 365）

Function NetDiscount(LookupItems As Variant, Discounts As Range, Optional Seperator As String = ",") As Variant
    Dim LookupArray() As String
    Dim LookupItem As Variant
    Dim idx As Variant
    Dim Discount As Double
    Dim OneOrMoreFound As Boolean
    
    LookupArray = Split(LookupItems, Seperator)
    Discount = 1#
    For Each LookupItem In LookupArray
        idx = Application.Match(LookupItem, Discounts.Columns(1), 0)
        If Not IsError(idx) Then
            OneOrMoreFound = True
            Discount = Discount * Discounts.Cells(idx, 2).Value2
        End If
    Next
    If Not OneOrMoreFound Then
        ' Return default value if no items found
        Discount = 0#
    End If
    NetDiscount = Discount
End Function

---

与您的问题无关，但您的活动代码中存在一个重大错误：如果您的“折扣类型”列表中包含另一个项目中包含的项目（例如“公民”和老年人“，并且较长的项目已经是选择，那么您的代码将不会添加较短的值，因为

If InStr(1, Oldvalue, Newvalue) = 0 Then

会在较长的值中找到较短的值。

这是一个重构版本，解决了这个问题和其他风格问题

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim OldValue As String
    Dim NewValue As String
    Dim Seperator As String
    Dim CombinedValue As String
    On Error GoTo ExitSub
    
    If Target.Count > 1 Then GoTo ExitSub
    If Target.Value = vbNullString Then GoTo ExitSub
    If Not Intersect(Target, Me.Columns(4)) Is Nothing Then
        If Not Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
            Application.EnableEvents = False
            Seperator = ", "
            NewValue = Target.Value
            Application.Undo
            OldValue = Target.Value
            
            If OldValue = vbNullString Then
                CombinedValue = Seperator & NewValue
            Else
                OldValue = Seperator & OldValue
                NewValue = Seperator & NewValue
                If InStr(1, OldValue, NewValue) = 0 Then
                    CombinedValue = OldValue & NewValue
                Else
                    CombinedValue = OldValue
                End If
            End If
            Target.Value = Mid$(CombinedValue, Len(Seperator) + 1)
        End If
    End If
    
ExitSub:
    Application.EnableEvents = True
End Sub