Sub fromExcelToAccess()

       Dim dbe As Object 'DAO.DBEngine
       Dim db  As Object 'DAO.Database
       Dim rst As Object 'DAO.Recordset
       Dim i As Long
          
       Set dbe = CreateObject("DAO.DBEngine.120")
       Set db = dbe.OpenDatabase("C:\...\file.accdb")
       Set rst = db.TableDefs("ИмяТаблицы").OpenRecordset
          
       For i = 1 To 10 'цикл по записям Excel
           rst.AddNew
               rst("Поле1").Value = "первое поле из Excel"
               rst("Поле2").Value = "второе поле из Excel"
               rst("Поле3").Value = "третье поле из Excel"
           rst.Update
       Next
          
End Sub

Public Sub AddNew()
      'Если хотя бы один из файлов 2007-2010, то
      'Const sConn As String = "Provider=Microsoft.ACE.OLEDB.12.0;Mode=Share Deny None;Data Source=c:\sap\db.accdb"
      Const sConn As String = "Provider=Microsoft.Jet.OLEDB.4.0;;Mode=Share Deny None;Data Source=c:\sap\db.mdb"
      Dim AddSQL As String
      Dim pConn As Object, AddRSet As Object, TableRSet As Object
      Set pConn = CreateObject("ADODB.Connection"): pConn.Open sConn
      'Поменять на Excel 12.0 для версий файлов 2007-2010 (путь и имя файла с импортируемыми в Access значениями)
      AddSQL = "Select t1.[Дата],t1.[Название],t1.[Данные] From [Excel 8.0;DATABASE=c:\SAP\book1.xls;HDR=YES].[Sheet1$] As t1"
      'Заменить TableName на название таблицы в Access
      AddSQL = AddSQL & " Left Join TableName As t2 On ((t1.[Дата]=t2.[Дата]) And (t1.[Название]=t2.[Название]) And (t1.[Данные]=t2.[Данные]))"
      AddSQL = AddSQL & " Where t2.[Дата] Is Null"
      Set AddRSet = CreateObject("ADODB.Recordset"): AddRSet.CursorLocation = 3
      AddRSet.Open AddSQL, pConn, 3, 1
      If AddRSet.RecordCount = 0 Then
          MsgBox "Нет новых записей"
      Else
          Set TableRSet = CreateObject("ADODB.Recordset"): TableRSet.CursorLocation = 3
          'Заменить TableName на название таблицы в Access
          TableRSet.Open "Select [Дата],[Название],[Данные] From TableName Where [Дата] Is Null", pConn, 3, 3
          Do Until AddRSet.EOF
              TableRSet.AddNew
              TableRSet("Дата").Value = AddRSet("Дата").Value
              TableRSet("Название").Value = AddRSet("Название").Value
              TableRSet("Данные").Value = AddRSet("Данные").Value
              AddRSet.MoveNext
          Loop
          TableRSet.Update
          TableRSet.Close
      End If
      AddRSet.Close: pConn.Close
End Sub

Sub fromExcelToAccess()

     Dim dbe As Object 'DAO.DBEngine
     Dim db  As Object 'DAO.Database
     Dim rst As Object 'DAO.Recordset
     Dim i As Long
          
     Set dbe = CreateObject("DAO.DBEngine.120")
     Set db = dbe.OpenDatabase("C:\...\Test.accdb")
     Set rst = db.TableDefs("Таблица1").OpenRecordset
          
     For i = 1 To Range("A" & Cells.Rows.Count).End(xlUp).Row - 1
             rst.AddNew
             rst("Поле1").Value = Range("a" & 1 + i).Value
             rst("Поле2").Value = Range("b" & 1 + i).Value
             rst("Поле3").Value = Range("c" & 1 + i).Value
         rst.Update
     Next
          
End Sub

      On Error Resume Next
      rst.Update
      On Error GoTo 0

Sub traverseRecordset()

     Dim dbe As Object 'DAO.DBEngine
     Dim db  As Object 'DAO.Database
     Dim rst As Object 'DAO.Recordset
          
     Set dbe = CreateObject("DAO.DBEngine.120")
     Set db = dbe.OpenDatabase("C:\...\file.accdb")
     Set rst = db.OpenRecordset("SELECT * FROM Таблица1 WHERE 1=1")
          
     Do While Not rst.EOF 'цикл по записям
      
         'бла-бла-бла: что-то делаем с очередной записью
         'например, "трогаем" значение первого поля
         Debug.Print rst.Fields(0).Value
          
         rst.MoveNext
     Loop
          
End Sub

      ExistsSQL = "Select t1.[Дата],t1.[Название],t1.[Данные] From [Excel 8.0;DATABASE=c:\SAP\book1.xls;HDR=YES].[Sheet1$] As t1"
      ExistsSQL = ExistsSQL & " Inner Join TableName As t2 On ((t1.[Дата]=t2.[Дата]) And (t1.[Название]=t2.[Название]) And (t1.[Данные]=t2.[Данные]))"
      Set ExistsRSet = CreateObject("ADODB.Recordset"): ExistsRSet.CursorLocation = 3
     ExistsRSet.Open ExistsSQL, pConn, 3, 1
      If ExistsRSet.RecordCount > 0 Then
          Set pSheet = ActiveWorkbook.Worksheets
          pSheet.Range("A1:C1").Value = Array("Дата", "Название", "Данные")
          pSheet.Range("A2").CopyFromRecordset ExistsRSet
          MsgBox "Создан лист дубликатов"
      End If
      ExistsRSet.Close

Public Function GetPKey()
      Dim fso As Object, sKey As String
      Set fso = CreateObject("Scripting.FileSystemObject")
      sKey = fso.GetTempName
      GetPKey = Mid$(sKey, 1, Len(sKey) - 4)
End Function