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

Question

I have an Excel tool for doing actuarial calculations on data from SQL. The tool imports the table from SQL to my Excel book then does some calculations on the data set.

I want to take the table from SQL (I use CopyFromRecordSet to paste into my spreadsheet) and rather insert that table into an Access db.

    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

I tried a plethora of methods, I spent dozens of hours googling. I assume that RecordSet is a virtual database in Excel where the data is stored. I want to dump that data into a new table in Access.

Answer 1

Create a sheet called AXIS in your workbook to hold the query results before importing into 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