Using Excel VBA to export data to MS Access table

I am currently using following code to export data from worksheet to MS Access database, the code is looping through each row and insert data to 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

Above code works fine for few hundred lines of records, but apparently it will be more data to export, Like 25000 records, is it possible to exp