VBA 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
复制

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

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