Import table from SQL to Access using Excel VBA - sql

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