如何用VBA基于列值创建动态下拉列表并实现数据自动复制？

步骤1：生成不重复等级的动态下拉列表 #

首先从Sheet1的B列提取不重复的等级值，作为下拉列表的数据源。我们用一个隐藏的辅助工作表存储这些唯一值，避免干扰主表操作。

打开VBA编辑器（按Alt+F11），双击ThisWorkbook，粘贴以下代码：

Private Sub Workbook_Open()
    Dim wsSource As Worksheet, wsHelper As Worksheet
    Dim lastRow As Long, i As Long
    Dim levelDict As Object
    
    ' 指定数据源工作表
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
    ' 检查辅助表是否存在，不存在则新建并隐藏
    On Error Resume Next
    Set wsHelper = ThisWorkbook.Sheets("Helper")
    On Error GoTo 0
    If wsHelper Is Nothing Then
        Set wsHelper = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        wsHelper.Name = "Helper"
        wsHelper.Visible = xlSheetHidden
    End If
    
    ' 清空辅助表旧数据
    wsHelper.Cells.Clear
    
    ' 用字典收集唯一等级值
    Set levelDict = CreateObject("Scripting.Dictionary")
    lastRow = wsSource.Cells(wsSource.Rows.Count, "B").End(xlUp).Row
    For i = 2 To lastRow ' 假设第一行是表头
        If Not levelDict.Exists(wsSource.Cells(i, "B").Value) Then
            levelDict.Add wsSource.Cells(i, "B").Value, ""
        End If
    Next i
    
    ' 将唯一值写入辅助表
    If levelDict.Count > 0 Then
        wsHelper.Range("A1").Resize(levelDict.Count).Value = Application.Transpose(levelDict.Keys)
    End If
    
    ' 给Sheet2的A2设置下拉列表验证
    With ThisWorkbook.Sheets("Sheet2").Range("A2").Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
             Formula1:="=Helper!$A$1:$A$" & levelDict.Count
        .InCellDropdown = True
        .ShowInput = True
    End With
    
    ' 释放对象
    Set levelDict = Nothing
    Set wsSource = Nothing
    Set wsHelper = Nothing
End Sub

步骤2：选择等级后自动填充对应姓名 #

当Sheet2的A2单元格选择等级时，自动筛选Sheet1中对应等级的姓名并复制到Sheet2的B列。

双击VBA编辑器中的Sheet2，粘贴以下代码：

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim lastRow As Long, targetRow As Long
    Dim selectedLevel As String
    
    ' 仅处理A2单元格的变化
    If Target.Address <> "$A$2" Then Exit Sub
    
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
    Set wsTarget = ThisWorkbook.Sheets("Sheet2")
    selectedLevel = Target.Value
    
    ' 清空B列旧数据（假设B1是表头，保留表头）
    wsTarget.Range("B2:B" & wsTarget.Cells(wsTarget.Rows.Count, "B").End(xlUp).Row).ClearContents
    
    ' 未选择等级则退出
    If selectedLevel = "" Then Exit Sub
    
    ' 遍历匹配等级，复制对应姓名
    lastRow = wsSource.Cells(wsSource.Rows.Count, "B").End(xlUp).Row
    targetRow = 2 ' 从B2开始填充
    For i = 2 To lastRow
        If wsSource.Cells(i, "B").Value = selectedLevel Then
            wsTarget.Cells(targetRow, "B").Value = wsSource.Cells(i, "A").Value
            targetRow = targetRow + 1
        End If
    Next i
    
    ' 释放对象
    Set wsSource = Nothing
    Set wsTarget = Nothing
End Sub

使用注意 #

1. 保存工作簿为.xlsm格式（启用宏的工作簿）
2. 重新打开工作簿后，Sheet2的A2会自动生成下拉列表
3. 选择等级后，Sheet2的B列会自动填充对应姓名

内容的提问来源于stack exchange，提问作者little turtle