使用Excel VBA将数据导出到MS Access表

Question

我目前正在使用以下代码将数据从工作表导出到MS Access数据库,代码循环遍历每一行并将数据插入MS Access Table.

Public Sub TransData()

Application.ScreenUpdating = False
Application.EnableAnimations = False
Application.EnableEvents = False
Application.DisplayAlerts = False

ActiveWorkbook.Worksheets("Folio_Data_original").Activate

Call MakeConnection("fdMasterTemp")

For i = 1 To rcount - 1
    rs.AddNew
    rs.Fields("fdName") = Cells(i + 1, 1).Value
    rs.Fields("fdDate") = Cells(i + 1, 2).Value
    rs.Update

Next i

Call CloseConnection

Application.ScreenUpdating = True
Application.EnableAnimations = True
Application.EnableEvents = True
Application.DisplayAlerts = True

End Sub

---

Public Function MakeConnection(TableName As String) As Boolean
'*********Routine to establish connection with database

   Dim DBFullName As String
   Dim cs As String

   DBFullName = Application.ActiveWorkbook.Path & "\FDData.mdb"

   cs = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & DBFullName & ";"

   Set cn = CreateObject("ADODB.Connection")

   If Not (cn.State = adStateOpen) Then
      cn.Open cs
   End If

   Set rs = CreateObject("ADODB.Recordset")

   If Not (rs.State = adStateOpen) Then
       rs.Open TableName, cn, adOpenKeyset, adLockOptimistic
   End If

End Function

---

Public Function CloseConnection() As Boolean
'*********Routine to close connection with database

On Error Resume Next
   If Not rs Is Nothing Then
       rs.Close
   End If


   If Not cn Is Nothing Then
       cn.Close
   End If
   CloseConnection = True
   Exit Function

End Function

上面的代码适用于几百行记录,但显然它将导出更多数据,如25000条记录,是否可以在不循环遍历所有记录的情况下导出,只需一条SQL INSERT语句即可将所有数据批量插入Ms.Access表一气呵成？

任何帮助都感激不尽.

编辑:问题已解决

只是为了获取信息,如果有人寻求这个,我已经做了很多搜索,并发现以下代码对我来说工作正常,并且由于SQL INSERT,它真的很快(27648条记录仅需3秒!!!! ):

Public Sub DoTrans()

  Set cn = CreateObject("ADODB.Connection")
  dbPath = Application.ActiveWorkbook.Path & "\FDData.mdb"
  dbWb = Application.ActiveWorkbook.FullName
  dbWs = Application.ActiveSheet.Name
  scn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbPath
  dsh = "[" & Application.ActiveSheet.Name & "$]"
  cn.Open scn

  ssql = "INSERT INTO fdFolio ([fdName], [fdOne], [fdTwo]) "
  ssql = ssql & "SELECT * FROM [Excel 8.0;HDR=YES;DATABASE=" & dbWb & "]." & dsh

  cn.Execute ssql

End Sub

仍在努力添加特定字段名称而不是使用"Select*",尝试了各种方法来添加字段名称,但现在无法使其工作.

Answer 1

是否可以导出而不循环遍历所有记录

对于有大量行的范围在Excel中,你可能会看到一些性能改进,如果你创建一个Access.Application在Excel对象,然后用它来导入 Excel数据导入Access.下面的代码位于包含以下测试数据的同一Excel文档中的VBA模块中

Option Explicit

Sub AccImport()
    Dim acc As New Access.Application
    acc.OpenCurrentDatabase "C:\Users\Public\Database1.accdb"
    acc.DoCmd.TransferSpreadsheet _
            TransferType:=acImport, _
            SpreadSheetType:=acSpreadsheetTypeExcel12Xml, _
            TableName:="tblExcelImport", _
            Filename:=Application.ActiveWorkbook.FullName, _
            HasFieldNames:=True, _
            Range:="Folio_Data_original$A1:B10"
    acc.CloseCurrentDatabase
    acc.Quit
    Set acc = Nothing
End Sub