Использование Excel VBA для экспорта данных в таблицу MS Access

В настоящее время я использую следующий код для экспорта данных из рабочего листа в базу данных MS Access, код перебирает каждую строку и вставляет данные в таблицу доступа MS.

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 (за 27 секунд за 27 секунд)!!!!):

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

Все еще работая над добавлением имени конкретных полей вместо использования "Выбрать *", попробовал различные способы добавления имен полей, но не может заставить их работать.