使用 Excel VBA 将表从 SQL 导入到 Access

Question

我有一个 Excel 工具，用于对 SQL 中的数据进行精算计算。该工具将表从 SQL 导入到我的 Excel 书中，然后对数据集进行一些计算。

我想从 SQL 中获取表格（我使用 CopyFromRecordSet 粘贴到我的电子表格中），而是将该表格插入到 Access 数据库中。

    Dim acc As Object
    Dim TblName As String, DBName As String, scn As String
    
    Set acc = CreateObject("Access.Application")
    Set rs = New ADODB.Recordset
       
    scn = ThisWorkbook.Worksheets("AXIS Tables").Range("A3").Value

    DBName = ThisWorkbook.Worksheets("AXIS Tables").Range("B3").Value

    Call CreateConnectionSQL.CreateConnectionSQL

    acc.OpenCurrentDatabase ActiveWorkbook.Path & "\" & scn & "\Input.accdb"
    
    rs.ActiveConnection = cn
    rs.CursorType = adOpenForwardOnly
    rs.LockType = adLockReadOnly
    rs.Source = "SELECT * FROM" DBName
    rs.Open
    
    
    TblName = "SAM"
    
    Call DoCmd.TransferDatabase(TransferType:=acImport, _
                            databaseName:=rs, _
                            ObjectType:=acTable, _
                            Source:=rs.Fields, _
                            Destination:=acc)
    
    rs.Close
    Call CreateConnectionSQL.CloseConnectionACC
    acc.CloseCurrentDatabase
    acc.Quit
    Set acc = Nothing

我尝试了很多方法，我花了几十个小时谷歌搜索。 我假设 RecordSet 是 Excel 中存储数据的虚拟数据库。 我想将该数据转储到 Access 中的新表中。

Answer 1

在您的工作簿中创建一个名为 AXIS 的工作表来保存查询结果，然后再导入到 Access 中。

Option Explicit

Sub CopyToAccess()

    Const TABLENAME As String = "AXIS"
    Const SHEETNAME As String = "AXIS" ' create this sheet
    Const SQL As String = "SELECT * FROM TABLE1"

    Dim acc As Object, cn As ADODB.Connection, rs As ADODB.Recordset
    Dim rng As Range, ws As Worksheet
    Dim sPath As String, sAddr As String, n As Long, i As Integer
    Dim scn As String, dbname As String, dbpath As String
    
    sPath = ThisWorkbook.Path
    With ThisWorkbook.Worksheets("AXIS Tables")
      scn = .Range("A3").Value
      dbname = .Range("B3").Value
    End With
    dbpath = sPath & "\" & scn & "\" & dbname
    
    ' connect and query sql database
    Set cn = CreateConnectionSQL
    Set rs = New ADODB.Recordset
    rs.ActiveConnection = cn
    rs.CursorType = adOpenForwardOnly
    rs.LockType = adLockReadOnly
    rs.Source = SQL
    rs.Open

    ' clear sheet
    Set ws = ThisWorkbook.Worksheets(SHEETNAME)
    ws.Cells.Clear
    
    ' set field names as header
    For i = 1 To rs.Fields.Count
       ws.Cells(1, i) = rs(i - 1).Name
    Next
    
    ' copy record set to sheet
    ws.Range("A2").CopyFromRecordset rs
    Set rng = ws.Range("A1").CurrentRegion
    n = rng.Rows.Count - 1
    sAddr = ws.Name & "!" & rng.AddressLocal
    sAddr = Replace(sAddr, "$", "") ' remove $ from address
    
    MsgBox n & " records imported to " & sAddr, vbInformation
    cn.Close

    ' open ACCESS
    Set acc = CreateObject("Access.Application")
    acc.OpenCurrentDatabase dbpath
    
    ' clear out any existing table
    On Error Resume Next
    acc.DoCmd.DeleteObject acTable, TABLENAME
    On Error GoTo 0
    
    ' export sheet into access
    acc.DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, TABLENAME, _
    sPath & "/" & ThisWorkbook.Name, True, sAddr
       
    ' finish
    acc.CloseCurrentDatabase
    acc.Quit
    Set acc = Nothing
    MsgBox "Export to " & dbpath & " table " & TABLENAME & " complete", vbInformation
    
End Sub

Function CreateConnectionSQL() As ADODB.Connection

    Const SERVER As String = "server"
    Const DB As String = "database"
    Const UID As String = "user"
    Const PWD As String = "password"
    
    Dim sConStr As String
    sConStr = "Driver={SQL Server Native Client 11.0};Server=" & SERVER & _
              ";Database=" & DB & ";Uid=" & UID & ";Pwd=" & PWD & ";"
    
    'Debug.Print sConStr
    Set CreateConnectionSQL = CreateObject("ADODB.Connection")
    CreateConnectionSQL.Open sConStr
    
End Function