嘿，我来帮你搞定这个动态下拉列表的问题！你的代码已经有了不错的开头思路，我来帮你补全并优化，确保下拉列表能随源数据的增减自动调整范围。

完整解决方案1：直接用OFFSET动态公式 #

这种方法不需要额外创建命名范围，直接在数据验证里嵌入动态公式，简单直接：

Sub AddDynamicDropdown()
    Dim sht As Worksheet
    Dim LastRow As Long
    Dim targetCol As Range
    Dim listRange As String
    
    ' 替换成你的目标工作表名称
    Set sht = Worksheets("*Name of main sheet*")
    
    ' 获取源数据的最后一行（假设源数据在A列，从A1开始）
    ' 如果源数据在其他列，把"A"改成对应列标（比如"C"）
    LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
    
    ' 构建动态范围公式：OFFSET会自动跟随源数据行数变化
    listRange = "=OFFSET(" & sht.Name & "!$A$1,0,0," & LastRow & ",1)"
    
    ' 设置要添加下拉列表的目标列（这里示例是B列，从B2到B列最后一行）
    ' 如果要给整列加，直接用 sht.Range("B:B")
    Set targetCol = sht.Range("B2:B" & sht.Cells(sht.Rows.Count, "B").End(xlUp).Row)
    
    ' 先清除目标列已有的数据验证，避免重复添加报错
    targetCol.Validation.Delete
    
    ' 添加数据验证下拉列表
    With targetCol.Validation
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
             Operator:=xlBetween, Formula1:=listRange
        .IgnoreBlank = True ' 允许空白单元格
        .InCellDropdown = True ' 显示下拉箭头
        .ShowInput = True ' 显示输入提示
        .ShowError = True ' 输入错误时提示
    End With
    
    MsgBox "动态下拉列表已搞定！"
End Sub

完整解决方案2：用动态命名范围（更灵活） #

如果需要在多个列或工作表复用这个下拉源，推荐用命名范围的方式，后续维护起来更方便：

Sub AddDynamicDropdownWithNamedRange()
    Dim sht As Worksheet
    Dim LastRow As Long
    Dim targetCol As Range
    Dim namedRangeName As String
    
    ' 自定义命名范围的名称（可以随便改，比如"ProductList"）
    namedRangeName = "DynamicList"
    ' 替换成你的目标工作表名称
    Set sht = Worksheets("*Name of main sheet*")
    
    ' 获取源数据最后一行（同样假设源在A列）
    LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
    
    ' 创建动态命名范围，这个范围会自动随源数据更新
    ThisWorkbook.Names.Add Name:=namedRangeName, _
        RefersToR1C1:="=OFFSET(" & sht.Name & "!R1C1,0,0," & LastRow & ",1)"
    
    ' 设置目标列（示例还是B列）
    Set targetCol = sht.Range("B2:B" & sht.Cells(sht.Rows.Count, "B").End(xlUp).Row)
    
    ' 清除原有验证
    targetCol.Validation.Delete
    
    ' 添加数据验证，直接引用命名范围
    With targetCol.Validation
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
             Operator:=xlBetween, Formula1:="=" & namedRangeName
        .IgnoreBlank = True
        .InCellDropdown = True
    End With
    
    MsgBox "基于命名范围的动态下拉列表已添加完成！"
End Sub

几个关键注意点： #

• 源数据连续性：如果源数据中间有空白行，End(xlUp)会停在第一个空白行上方，导致范围不完整。这时可以改用Find方法获取最后一行：

  LastRow = sht.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  

• 目标列调整：根据你的实际需求修改目标列的范围，比如要给C列加，就把"B2:B..."改成"C2:C..."。
• 宏启用：确保你的工作簿启用了宏（保存为.xlsm格式），否则代码不会执行。

内容的提问来源于stack exchange，提问作者Andrew Silaghi