如何使用VBA从excel中的列表框中进行多选得到结果？

Question

我想要完成的是：

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

因为我有多种折扣类型，一个简单的 if 语句是行不通的，因为我可能 select 一次以任何顺序 select 两个以上的折扣。请帮忙，因为我是 VBA 的新手。谢谢！

这是我用于下拉列表框中多个 selection 的代码。注意：我从网上复制了这段代码。

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

如何使用VBA从excel中的列表框中进行多选得到结果？

How to get results based on multiple selection from the list box in excel using VBA?

excel

vba

listbox