VBA SQL 跨工作簿查询

Excel VBA练习 2021-07-15

2707

今天周末,突然感觉好久没练窗体了

恰好在群里潜水看到有网友咨询如何跨工作簿复制指定工作表到当前表的问题

为此,小编用SQL结合窗体做了个查询工具,但是使用SQL只能返回记录的值,如果需要把原表的公式,格式等复制过来,就需要用到workbook的方法了,关于WorkBook(工作簿)WorkSheet(工作表)我们以后往下练习

先看下SQL的效果,如下图所示

画的有点丑..

窗体代码如下

Option Explicit


Private Sub CommandButton1_Click() '获取路径
    Dim strPath$
    With Application.FileDialog(msoFileDialogFilePicker)
        If .Show Then
            strPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    Me.TextBox1.Text = strPath
End Sub


Private Sub CommandButton2_Click() '代码执行
    Dim strSQL$, S$, intX&, YesNo&
    Dim Conn As Object, Rec As Object
    Dim aField, strConn$
    On Error Resume Next
    Set Conn = CreateObject("Adodb.Connection")
    If Application.Version < 12 Then '判断Excel的版本号,以使用不同的连接字符串
        Conn.Open "Provider=Microsoft.ACE.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=yes;IMEX=0';Data Source=" & Me.TextBox1.Text
    Else
        Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes;IMEX=0';Data Source=" & Me.TextBox1.Text
    End If


    With Me
        If .ListBox3.ListCount = 0 Then
            strSQL = "Select * From [" & .ListBox1.Text & "]"
        Else
            For intX = .ListBox3.ListCount - 1 To 0 Step -1
                S = S & ",[" & .ListBox3.List(intX) & "]"
            Next
            strSQL = "Select " & Mid(S, 2) & " From [" & .ListBox1.Text & "]"
        End If
    End With
    Set Rec = Conn.Execute(strSQL)
    ReDim aField(1 To Rec.Fields.Count)
    For intX = 0 To Rec.Fields.Count - 1
        aField(intX + 1) = Rec.Fields(intX).Name
    Next
    YesNo = MsgBox("是否覆盖本表", vbYesNo, "Excel VBA练习提示!!")
    If YesNo = 7 Then
        Sheets.Add after:=Sheets(Sheets.Count)
    End If
    With ActiveSheet
        .Cells.Clear
        .Range("A1").Resize(, UBound(aField)) = aField
        .Range("A2").CopyFromRecordset Rec
        .Columns.AutoFit
        .UsedRange.Borders.LineStyle = 1
    End With
    Conn.Close
    Set Rec = Nothing
    Set Conn = Nothing
    Me.ListBox3.Clear
    Call Update_Field '更新下
End Sub


Private Sub CommandButton3_Click() '选择
    Dim intX&
    With Me
        If .ListBox2.ListIndex = -1 Then Exit Sub '未选择则退出
        With .ListBox2
            For intX = .ListCount - 1 To 0 Step -1
                If .Selected(intX) Then
                    Me.ListBox3.AddItem .List(intX)
                    .RemoveItem (intX)
                End If
            Next
        End With
    End With
End Sub


Private Sub CommandButton4_Click() '取消
    Dim intX&
    With Me
        If .ListBox3.ListIndex = -1 Then Exit Sub '未选择则退出
        With .ListBox3
            For intX = .ListCount - 1 To 0 Step -1
                If .Selected(intX) Then
                    Me.ListBox2.AddItem .List(intX)
                    .RemoveItem (intX)
                End If
            Next
        End With
    End With
End Sub


Private Sub ListBox1_Click() '点击工作表更新字段
    Call Update_Field
End Sub


Sub Update_Field() '字段更新
    Dim Rec As Object, Conn As Object
    Dim strSQL$, intX&
    On Error Resume Next
    Set Conn = CreateObject("Adodb.connection")
    Set Rec = CreateObject("adodb.recordset")
    If Application.Version < 12 Then '判断Excel的版本号,以使用不同的连接字符串
        Conn.Open "Provider=Microsoft.ACE.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=yes;IMEX=0';Data Source=" & Me.TextBox1.Text
    Else
        Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes;IMEX=0';Data Source=" & Me.TextBox1.Text
    End If
    strSQL = "select * from [" & Me.ListBox1.Text & "]"
    Rec.Open strSQL, Conn, 1, 3
    With Me.ListBox2
        .Clear
        For intX = 0 To Rec.Fields.Count - 1
            .AddItem Rec.Fields(intX).Name
        Next
    End With
    Set Conn = Nothing: Set Rec = Nothing
End Sub


Private Sub TextBox1_Change() '路径改变发生的事件
    Dim Conn As Object, Rec As Object
    On Error Resume Next
    Me.ListBox2.Clear
    Me.ListBox3.Clear
    Set Conn = CreateObject("adodb.connection")
    If Application.Version < 12 Then '判断Excel的版本号,以使用不同的连接字符串
        Conn.Open "Provider=Microsoft.ACE.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=yes;IMEX=0';Data Source=" & Me.TextBox1.Text
    Else
        Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes;IMEX=0';Data Source=" & Me.TextBox1.Text
    End If
    Set Rec = Conn.openschema(20)
    With Me.ListBox1
        .Clear
        Do Until Rec.EOF
            If Rec!TABLE_TYPE = "TABLE" Then
                If Right(Rec!TABLE_NAME, 1) = "$" Then
                    .AddItem Rec!TABLE_NAME
                End If
            End If
            Rec.MoveNext
        Loop
    End With
End Sub


Private Sub UserForm_Initialize() '加载窗体初始化
    With Me
        .TextBox1.Text = ThisWorkbook.FullName
        With .ListBox2
            .MultiSelect = fmMultiSelectMulti
            .ListStyle = fmListStyleOption
        End With
        With .ListBox3
            .MultiSelect = fmMultiSelectMulti
            .ListStyle = fmListStyleOption
        End With
    End With
End Sub

模块代码

Sub GetData(control As IRibbonControl)
    UserForm1.Show
End Sub

今天代码有点冗余,小编偷懒,复制粘贴复制粘贴...也没注释,这是个坏习惯...过段时间回头看这段代码估计会稀里糊涂的,有兴趣的小伙伴可以封装个SQL的查询代码,在代码中调用,并且添加上注释...在发给小编

有细心的小伙伴可能会发现小编之前写Conn.Open的连接语句都是Data Source=" & ThisWorkbook.FullName,连接当前工作簿的表格,而今天的和之前有点不一样

其实跨工作簿查询只需要更改Conn.Open中的"DataSource="&Me.TextBox1.Text"

也就是所需要连接工作簿的指定路径

"Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes;IMEX=0';Data Source=C:\Users\Administrator\Desktop\数据源.xlsx"

代码中直接指定了需要连接工作簿的完整名称,在SQL语句中使用常规的方法写即可完成跨工作博查询

但是,如果需要是连接当前工作簿,而查询别的工作簿的时候,在SQL语句中就需要更改下

Select 字段 From [Excel 12.0;DataBase=需要查询工作簿的完整路径].[需要查询的工作表$]

这些都是固定的用法,小伙伴稍微记住下即可,忘了可以翻下文章看看

Excel 12.0是目标工作簿的版本号

DataBase是指定查询工作簿的路径,第二个中括号是指定需要查询的工作表名称

...

示例文件下载

链接：https://pan.baidu.com/s/1lbEWThdUX_NN3tBP-l_EDg

提取码：abcd

收工!

如果小伙伴有好的思路,可以给小编留言

文章如果觉得有用,点个赞,小伙伴的每一次点赞和转发都是小编原创的动力

关注公众号↓

数据库

文章转载自Excel VBA练习，如果涉嫌侵权，请发送邮件至：contact@modb.pro进行举报，并提供相关证据，一经查实，墨天轮将立刻删除相关内容。

VBA SQL 跨工作簿查询

评论