如何将SQL Server表Landowner列数据导入Excel单元格下拉列表？

原代码的问题分析 #

当前代码只显示第一条记录，核心原因有两个：

• 把所有地主名拼成逗号分隔的字符串后，试图用Split写入单个单元格（B2），但单个单元格只能接收数组的第一个元素，所以只保留了第一条数据。
• 数据验证的源设置为B2本身，自然只能读取到这一个值。

修改后的完整代码 #

直接把SQL查询到的所有地主名写入工作表的隐藏区域（比如Sheet1的A列），然后让数据验证引用这个区域，就能显示全部选项：

Sub PopulateDropdownList()
    Dim conn As Object
    Dim rs As Object
    Dim strConn As String
    Dim strSQL As String
    Dim ws As Worksheet
    Dim optRange As Range
    Dim lastRow As Long
    
    ' 连接字符串
    strConn = "Provider=MSOLEDBSQL;Data Source=NICKS_LAPTOP;" & _
              "Initial Catalog=pursuant;Integrated Security=SSPI;"
    
    ' 初始化连接和记录集
    Set conn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    ' 清理旧数据：清空存放选项的区域（这里用A列，可根据需求调整）
    ws.Range("A:A").ClearContents
    
    ' 打开连接并执行查询，过滤空值避免无效选项
    conn.Open strSQL
    strSQL = "SELECT DISTINCT Landowner FROM [Pursuant] WHERE Landowner IS NOT NULL"
    rs.Open strSQL, conn
    
    ' 把记录集数据直接写入工作表A列，高效无拼接错误
    If Not rs.EOF Then
        ws.Range("A1").CopyFromRecordset rs
    End If
    
    ' 关闭连接和记录集
    rs.Close
    conn.Close
    
    ' 获取选项区域的最后一行，确定数据验证的引用范围
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    Set optRange = ws.Range("A1:A" & lastRow)
    
    ' 清理B2旧的验证规则
    ws.Range("B2").Validation.Delete
    
    ' 给B2添加数据验证，引用A列的全部选项
    With ws.Range("B2").Validation
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
             Formula1:="=" & optRange.Address
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowInput = True
        .ShowError = True
    End With
    
    ' 可选：隐藏存放选项的A列，避免误操作
    ws.Columns("A").Hidden = True
End Sub

代码改动说明 #

• 去掉了冗余的字符串拼接逻辑，用CopyFromRecordset直接写入查询结果，效率更高且避免拼接错误。
• 添加空值过滤，避免下拉列表出现无效空选项。
• 数据验证直接指向存放所有选项的区域，确保显示全部记录。
• 可选隐藏选项列，保持工作表整洁。

后续实现：选择地主名后自动查询相关数据 #

在Sheet1的代码模块中添加以下事件代码，当B2的值变化时自动查询并展示对应数据：

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim conn As Object
    Dim rs As Object
    Dim strConn As String
    Dim strSQL As String
    Dim ws As Worksheet
    
    ' 仅监控B2单元格的变化
    If Target.Address <> "$B$2" Then Exit Sub
    If Target.Value = "" Then Exit Sub
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    strConn = "Provider=MSOLEDBSQL;Data Source=NICKS_LAPTOP;" & _
              "Initial Catalog=pursuant;Integrated Security=SSPI;"
    
    Set conn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    
    ' 构造查询SQL，处理单引号转义避免语法错误
    strSQL = "SELECT * FROM [Pursuant] WHERE Landowner = '" & Replace(Target.Value, "'", "''") & "'"
    
    conn.Open strConn
    rs.Open strSQL, conn
    
    ' 清空旧数据（示例用D1开始的区域），写入新查询结果
    ws.Range("D1:Z1000").ClearContents
    If Not rs.EOF Then
        ws.Range("D1").CopyFromRecordset rs
        ' 可选：写入表头
        Dim i As Integer
        For i = 0 To rs.Fields.Count - 1
            ws.Cells(1, 4 + i).Value = rs.Fields(i).Name
        Next i
    End If
    
    rs.Close
    conn.Close
End Sub

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