使用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