VBA学习(44)：VBA+SQL赋能的Excel动态查询系统设计

  案例

工作簿内含有多个工作表的数据，如何在新的工作表根据指定条件快速查询出对应的数据呢？

数据源表[员工花名册]

Excel动态查询系统效果演示

Excel动态查询系统

利用VBA+SQL设计了Excel动态查询系统，在此分享给大家。

目前，已完成同时支持模糊/精确查询的基本功能。有机会的话，也会在这一稿的基础上完善更多的查询功能，比如介值查询等。

主界面和操作指南

设计思路与核心代码

1.数据源表动态加载

设计思路：自定义函数GetSheetsName，获取所有工作表名；并将所有工作表名作为B1单元格数据验证的序列来源。

实现效果：如果我们新增工作表，会自动添加在数据源表的下拉框中；如果删除某个工作表，则自动从下拉框中删除。

'获取所有工作表名
Function GetSheetsName()
    Application.Volatile
    Dim arr
    ReDim arr(1 To ActiveWorkbook.Sheets.Count - 1)
    Dim sht As Worksheet, i As Integer
    i = 1
    For Each sht In ActiveWorkbook.Sheets
        If sht.Name <> ActiveSheet.Name Then
            arr(i) = sht.Name
            i = i + 1
        End If
    Next
    GetSheetsName = WorksheetFunction.Transpose(arr)
End Function

2.查询字段动态更新

设计思路：如果数据源表（B1单元格）改变，查询字段（A3单元格）会自动更新并加载。

Private Sub Worksheet_Change(ByVal Target As Range)
    If Range("B1") = "" Then
        Exit Sub
    End If
    If Target.Row = 1 And Target.Column = 2 Then
        '清空A3单元格的数据
        Range("A3").Value = ""
        '获取数据源表的标题行
        Dim cond As String, searchSht As Worksheet, lastColumn As Integer
        Set searchSht = Sheets(Range("B1").Value)
        lastColumn = searchSht.Range("a1").End(xlToRight).Column
        cond = "=" & Range("B1") & "!" & searchSht.Range("a1").Resize(1, lastColumn).Address
        '数据验证
        With Range("A3").Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:=cond
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .IMEMode = xlIMEModeNoControl
            .ShowInput = True
            .ShowError = True
        End With
    End If
End Sub

3.查询按钮

Sub SQL动态查询()
    If ActiveSheet.Range("B1") = "" Then
        MsgBox ("请在B1单元格，下拉选择数据源表")
        Exit Sub
    End If
    If ActiveSheet.Range("A3") = "" Then
        MsgBox ("请在A3单元格，下拉选择查询字段")
        Exit Sub
    End If    
    If WorksheetFunction.CountA(Rows(9)) <> 0 Then
        ActiveSheet.Rows("9:65536").Delete
    End If
    
    Dim shtTable As String
    shtTable = "[" & ActiveSheet.Range("B1") & "$]"
    
    Dim conn As Object
    Set conn = CreateObject("ADODB.Connection")
    conn.Open "provider=microsoft.ace.oledb.12.0;extended properties='excel 12.0;HDR=YES';data source='" & ActiveWorkbook.FullName & "'"

    Dim sql As String
    If ActiveSheet.Range("c3") = "精确查询" Then
        sql = "select * from " & shtTable & " where " _
            & ActiveSheet.Range("a3") & " like '" & ActiveSheet.Range("a3").Offset(0, 1) & "'"
    Else
        sql = "select * from " & shtTable & " where " _
            & ActiveSheet.Range("a3") & " like '%" & ActiveSheet.Range("a3").Offset(0, 1) & "%'"
    End If
    
    Dim rs As Object
    Set rs = CreateObject("ADODB.Recordset")
    Set rs = conn.Execute(sql)
    
    Dim i As Integer
    For i = 0 To rs.Fields.Count - 1
        ActiveSheet.Cells(8, i + 1) = rs.Fields(i).Name
    Next
    
    ActiveSheet.Range("a9").CopyFromRecordset rs
    rs.Close: Set rs = Nothing
    conn.Close: Set conn = Nothing
End Sub

技术交流，软件开发，欢迎微信沟通：