如何用VBA创建Excel弹窗，实现自定义列数据筛选删除

要实现「弹窗选择需保留的姓名，删除未选中行」的需求，我们可以通过用户窗体+字典去重+反向删除行的组合方式完成，以下是完整实现步骤和代码：

1. 创建用户窗体 #

打开VBA编辑器（Alt+F11），按以下步骤操作：

• 右键点击左侧项目资源管理器 → 插入 → 用户窗体；
• 在窗体上添加1个ListBox控件，设置其MultiSelect属性为1 - fmMultiSelectMulti（允许多选）；
• 添加2个命令按钮，分别设置Caption为「确定」和「取消」，命名为cmdOK和cmdCancel。

2. 窗体代码（粘贴到用户窗体模块） #

Private Sub cmdCancel_Click()
    Me.Hide
End Sub

Private Sub cmdOK_Click()
    Me.Tag = "OK"
    Me.Hide
End Sub

3. 主功能代码（粘贴到标准模块） #

Public Sub SelectAndKeepNames()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim cell As Range
    Dim uniqueNames As Object
    Dim selectedNames As Variant
    Dim i As Integer
    Dim keepArr As Variant
    Dim keepCount As Integer
    
    ' 指定目标工作表（可替换为Sheets("你的表名")）
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' 提取列A的唯一非空值（跳过第1行表头）
    Set uniqueNames = CreateObject("Scripting.Dictionary")
    For Each cell In ws.Range("A2:A" & lastRow)
        If cell.Value <> "" And Not uniqueNames.Exists(cell.Value) Then
            uniqueNames.Add cell.Value, cell.Value
        End If
    Next cell
    
    ' 无数据时提示退出
    If uniqueNames.Count = 0 Then
        MsgBox "列A中无有效数据可选择！", vbExclamation
        Exit Sub
    End If
    
    ' 将唯一名称加载到ListBox
    With frmSelectNames.lstNames
        .Clear
        .List = uniqueNames.Keys
    End With
    
    ' 显示选择窗体
    frmSelectNames.Tag = ""
    frmSelectNames.Show vbModal
    
    ' 用户点击取消则退出
    If frmSelectNames.Tag <> "OK" Then
        Unload frmSelectNames
        Exit Sub
    End If
    
    ' 收集用户选中的名称
    With frmSelectNames.lstNames
        ReDim keepArr(0 To .ListCount - 1)
        keepCount = 0
        For i = 0 To .ListCount - 1
            If .Selected(i) Then
                keepArr(keepCount) = .List(i)
                keepCount = keepCount + 1
            End If
        Next i
        ReDim Preserve keepArr(0 To keepCount - 1)
    End With
    Unload frmSelectNames
    
    ' 未选中任何名称时提示退出
    If keepCount = 0 Then
        MsgBox "未选择任何需保留的名称！", vbExclamation
        Exit Sub
    End If
    
    ' 从下往上删除未选中行（避免索引错位漏删）
    Application.ScreenUpdating = False
    For i = lastRow To 2 Step -1
        If ws.Cells(i, "A").Value <> "" And Not IsInArray(ws.Cells(i, "A").Value, keepArr) Then
            ws.Rows(i).Delete
        End If
    Next i
    Application.ScreenUpdating = True
    
    MsgBox "操作完成！已保留" & keepCount & "类名称对应的行。", vbInformation
End Sub

' 辅助函数：检查值是否在目标数组中
Private Function IsInArray(val As Variant, arr As Variant) As Boolean
    Dim element As Variant
    For Each element In arr
        If element = val Then
            IsInArray = True
            Exit Function
        End If
    Next element
    IsInArray = False
End Function

关键逻辑说明 #

• 唯一值提取：借助Scripting.Dictionary自动去重，确保弹窗只显示列A中不重复的姓名；
• 多选弹窗：通过设置ListBox的多选属性，支持用户同时选择多个需保留的姓名；
• 反向删除：从最后一行往上遍历删除，解决正向删除时行索引错位导致的漏删问题；
• 性能优化：关闭ScreenUpdating减少屏幕闪烁，提升运行速度。

内容的提问来源于stack exchange，提问作者Matt Laming