VBA 清除下拉列表中的内容

VBA Clear Contents in Drop Down List

我创建了一个下拉列表,每次您 select 下拉列表中的新内容都会添加到单元格中已有的内容中。问题是,我正在尝试找到一种方法来清除它,但我认为我的顺序有误。这是代码:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim lUsed As Long
If Target.Count > 1 Then GoTo exitHandler

On Error Resume Next
Set rngDV = Worksheets("Contact Log").Range("AE:AE,AI:AI,AM:AM,AQ:AQ,AU:AU,AY:AY,BC:BC,BG:BG,BK:BK,BO:BO,BS:BS,BW:BW,CA:CA,CE:CE,CI:CI")

On Error GoTo exitHandler
If rngDV Is Nothing Then GoTo exitHandler

If Intersect(Target, rngDV) Is Nothing Then
   'do nothing
Else
  Application.EnableEvents = False
  newVal = Target.Value
  Application.Undo
  oldVal = Target.Value
  Target.Value = newVal

  If oldVal = "" Then
    'do nothing
  Else
    If newVal = "" Then
      'do nothing
    Else
      lUsed = InStr(1, oldVal, newVal)
      If lUsed > 0 Then
        If newVal = "CLEAR" Then
          Selection.ClearContents
        ElseIf Right(oldVal, Len(newVal)) = newVal Then
          Target.Value = Left(oldVal, Len(oldVal) - Len(newVal) - 2)
        Else
           Target.Value = Replace(oldVal, newVal & ", ", "")
        End If
      Else
        Target.Value = oldVal & ", " & newVal
      End If
    End If
  End If
End If

exitHandler:
  Application.EnableEvents = True
End Sub

我遇到的问题是,有时,如果我 select 从下拉菜单中清除,它会将其添加到列表中,而不是清除单元格的内容。发生这种情况时,select再次清除将成功清除单元格内容。

希望这是有道理的,如果你需要我,我会澄清。出现此问题是因为我的 If 语句的顺序错误吗?

感谢您抽出宝贵时间!祝你有美好的一天!

在单元格中复制之前清除内容:

    If oldVal = "" Then
      'do nothing
      Else
      If newVal = "" Then
      'do nothing
      Else
        If newVal = "CLEAR" Then
          Selection.ClearContents
          GoTo exitHandler
        end if
        .....

第一次输入 "CLEAR" 时,lUsed 是 0 因为你没有那个字符串在 old 值所以你没有通过If lUsed > 0 Then 检查,因此未达到 If newVal = "CLEAR" Then 检查

所以你必须把``If newVal = "CLEAR"check before theIf lUsed > 0 Then` one

正如您对代码的这个小小的重构:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngDV As Range
    Dim oldVal As String
    Dim newVal As String

    If Target.count > 1 Then Exit Sub

    Set rngDV = Intersect(UsedRange, Range("AE:AE,AI:AI,AM:AM,AQ:AQ,AU:AU,AY:AY,BC:BC,BG:BG,BK:BK,BO:BO,BS:BS,BW:BW,CA:CA,CE:CE,CI:CI"))

    If Intersect(Target, rngDV) Is Nothing Then Exit Sub

    Application.EnableEvents = False
    On Error GoTo exitHandler

    newVal = Target.Value
    Select Case UCase(newVal)
        Case "CLEAR"
            Target.ClearContents

        Case vbNullString
            'do nothing

        Case Else
            Application.Undo
            oldVal = Target.Value
            If oldVal <> "" Then
                If InStr(1, oldVal, newVal) > 0 Then
                    If Right(oldVal, Len(newVal)) = newVal Then
                        Target.Value = Left(oldVal, Len(oldVal) - Len(newVal) - 2)
                    Else
                        Target.Value = Replace(oldVal, newVal & ", ", "")
                    End If
                Else
                    Target.Value = oldVal & ", " & newVal
                End If
            End If

        End Select

exitHandler:
    Application.EnableEvents = True
End Sub

仍然存在一个弱点,即在 On Error GoTo exitHandler 语句之后可能出现的每个错误都会导致您结束该子程序。

虽然您可能想处理 Target.Value = Left(oldVal, Len(oldVal) - Len(newVal) - 2) 当输入选择作为第二个值时他选择的与第一个值相同的错误