Vba 从填充我的列表框的范围中删除值

大家好，我有两个列表框。第一个列表框包含所有可供选择的项目。选择项目后，用户单击“添加”命令按钮，将该值复制到第二个列表框的范围中。我相信你们大多数人都见过类似的添加/删除列表框

Sub remove()


Dim r As Long
Dim al As ListBox

Dim d As Range
Dim dd As Range
Dim allpick As Worksheet


Set al = Worksheets("LISTBOX").ListBoxes("listselected")
Set allpick = Worksheets("columns")
Set dd = allpick.Range("selectedNAMES")


With al
    For r = 1 To .ListCount
        If .selected(r) Then
            For Each d In dd
                If d.Value = .List(r) Then
                d.ClearContents
                End If
            Next d
        End If

    Next r
End With

End Sub

这两个列表框都是通过插入控件创建的，它们由隐藏工作表上的输入范围项填充

Sub remove()


Dim r As Long
Dim al As ListBox

Dim d As Range
Dim dd As Range
Dim allpick As Worksheet


Set al = Worksheets("LISTBOX").ListBoxes("listselected")
Set allpick = Worksheets("columns")
Set dd = allpick.Range("selectedNAMES")


With al
    For r = 1 To .ListCount
        If .selected(r) Then
            For Each d In dd
                If d.Value = .List(r) Then
                d.ClearContents
                End If
            Next d
        End If

    Next r
End With

End Sub

这里是我的问题：添加名称很好，但是我创建的“删除”过程似乎需要很长时间才能完成，因为项目列表可能超过200个项目

Sub remove()


Dim r As Long
Dim al As ListBox

Dim d As Range
Dim dd As Range
Dim allpick As Worksheet


Set al = Worksheets("LISTBOX").ListBoxes("listselected")
Set allpick = Worksheets("columns")
Set dd = allpick.Range("selectedNAMES")


With al
    For r = 1 To .ListCount
        If .selected(r) Then
            For Each d In dd
                If d.Value = .List(r) Then
                d.ClearContents
                End If
            Next d
        End If

    Next r
End With

End Sub

我使用以下代码将选定的列表框值与输入范围值匹配，然后清除输入范围中单元格的内容：

Sub remove()


Dim r As Long
Dim al As ListBox

Dim d As Range
Dim dd As Range
Dim allpick As Worksheet


Set al = Worksheets("LISTBOX").ListBoxes("listselected")
Set allpick = Worksheets("columns")
Set dd = allpick.Range("selectedNAMES")


With al
    For r = 1 To .ListCount
        If .selected(r) Then
            For Each d In dd
                If d.Value = .List(r) Then
                d.ClearContents
                End If
            Next d
        End If

    Next r
End With

End Sub

---

是否有其他代码或结构可供我使用，这样就不用花那么长时间来完成？

我使用了评论员所述的find函数，并在下面编写了代码。这是快得多，正是我想要的。然而，我不知道在“如果单元格是空的，那么”之后应该放什么，所以我只使用了calculate。有什么建议吗

Sub remove()


Dim r As Long
Dim al As ListBox

Dim d As Range
Dim dd As Range
Dim allpick As Worksheet


Set al = Worksheets("LISTBOX").ListBoxes("listselected")
Set allpick = Worksheets("columns")
Set dd = allpick.Range("selectedNAMES")


With al
    For r = 1 To .ListCount
        If .selected(r) Then
            For Each d In dd
                If d.Value = .List(r) Then
                d.ClearContents
                End If
            Next d
        End If

    Next r
End With

End Sub

Dim r As Long
Dim al As ListBox
Dim strNAME As String
Dim names As Worksheet
Set names = Worksheets("names")
Set al = Worksheets("HOME").ListBoxes("selectednames")


With al
    For r = 1 To .ListCount
        If .Selected(r) Then
        strNAME = .List(r)
        Set cell = names.Range("currentnames").Find(What:=strNAME)

            If cell Is Nothing Then
                Calculate

            Else: cell.ClearContents
            End If
        End If
    Next r
End With

---

如果使用

Find/FindNext

或

AutoFilter

而不是在所有单元格中循环，则速度可能会更快。以下是

Find

方法的相关代码。非常感谢，这肯定会使它更快。如果您已经完成了代码，那么其他人将其添加为答案并将其标记为已回答将非常有帮助。