Question

我需要使用MultiSelect下拉菜单创建启用宏的excelsheet。

用户选择一个下拉列表，然后将值附加到带有逗号（，）分隔的单元格中。
如果用户再次选择了已选择的值，则应将其从列表中删除。

通过遵循代码，我能够实现它的第一部分，但无法实现第二部分。

    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Oldvalue As String
    Dim Newvalue As String
    Application.EnableEvents = True
    On Error GoTo Exitsub
    If Target.Address = "$D$2" 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

如何实现第2部分？请建议。

Answer 1

你可以替代：

If InStr(1, Oldvalue, Newvalue) = 0 Then
    Target.Value = Oldvalue & ", " & Newvalue

使用：

    If InStr(1, Oldvalue, Newvalue) = 0 Then
        Target.Value = Oldvalue & ", " & Newvalue
    Else
        Target.Value = Replace(Target.Value, Newvalue, "") ' remove value from list
        If Right(Target.Value, 1) = "," Then 'if removed value was the last value of the list
            Target.Value = Left(Target.Value, Len(Target.Value) - 1) ' remove ending comma
        ElseIf Left(Target.Value, 1) = "," Then 'if removed value was the first value of the list
            Target.Value = Mid(Target.Value, 2) ' remove leading comma
        Else ' removed value was in the middle of the list
            Target.Value = Replace(Target.Value, ",,", "") ' remove double comma
        End If
    End If

Answer 2

我建议类似@displayname，但是会使用for循环并替换你的部分代码。

  Dim substrings() As String
    substrings = Split(Oldvalue, ", ")
    Target.Value = ""
    Dim i As Integer
    For i = LBound(substrings) To UBound(substrings)
        If Not (substrings(i) = Newvalue) Then
          Target.Value = Target.Value & ", " & substrings(i)
        End If
    Next i

Answer 3

我使用了基于@RedBoy和@ yser9817739的代码，并改进并修复了问题。我还添加了用于复制/粘贴和自动填充的支票。

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim sOldvalue As String
    Dim sNewvalue As String
    Dim substrings() As String
    Dim i As Integer
    Dim bFound As Boolean: bFound = False
    Dim sUndoList As String

    Application.EnableEvents = True
    On Error GoTo Exitsub

    sUndoList = Application.CommandBars("Standard").Controls("&Undo").List(1)
    If Left(sUndoList, 5) = "Paste" Or sUndoList = "Auto Fill" Then GoTo Exitsub

    If Target.Address = "$D$2" Then
        If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
            GoTo Exitsub
        Else
            'Adding first item
            If Trim(Target.Value) = "" Then
                GoTo Exitsub
            Else
                Application.EnableEvents = False
                sNewvalue = Target.Value
                Application.Undo
                sOldvalue = Target.Value
                If Trim(sOldvalue) = "" Then
                    Target.Value = sNewvalue
                Else
                    substrings = Split(sOldvalue, ",")
                    For i = LBound(substrings) To UBound(substrings)
                        If Trim(substrings(i)) = Trim(sNewvalue) Then bFound = True
                    Next i
                    If Not bFound Then
                        Target.Value = sOldvalue & "," & sNewvalue
                    Else
                        Target.Value = ""
                        For i = LBound(substrings) To UBound(substrings)
                            If Not (Trim(substrings(i)) = Trim(sNewvalue)) And Len(Trim(substrings(i))) <> 0 Then
                                If Len(Target.Value) = 0 Then
                                    Target.Value = Trim(substrings(i))
                                Else
                                    Target.Value = Target.Value & "," & Trim(substrings(i))
                                End If
                            End If
                        Next i
                    End If
                End If
            End If
        End If
    End If

    Application.EnableEvents = True
Exitsub:
    Application.EnableEvents = True
End Sub

使用宏在Excel中进行MultiSelect，如何取消选择选择

3 个答案: