Problème vba transfert excel-> access

Bonjours , j'ai un petit problème, je doit pour mon travail en entreprise faire un programme en vba qui transfert des données souhaité d'une page excel vers un base de donnée acess j'ai pour l'instant ce programme :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
  Sub ADOFromExcelToAccess()
        ' on se connecte a la base de donnée
        Dim cn As ADODB.Connection, rs As ADODB.Recordset, r As Long
 
        Set cn = New ADODB.Connection
        cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & "Data Source=D:\cours\entreprise\Fédération.mdb;"
 
        ' open a recordset
       Set rs = New ADODB.Recordset
       rs.Open "rapport_annuel_asst", cn, adOpenKeyset, adLockOptimistic, adCmdTable
 
       ' all records in a table
 
       r = 3 ' the start row in the worksheet
       Do While Len(Range("B" & r).Formula) > 0
           With rs
               .AddNew ' create a new record
 
               ' add values to each field in the record
               .Fields("Exercice-1") = Range("B10:B16").Select
               ' add more fields if necessary...
 
               .Update
           End With
           r = r + 1
       Loop
 
       rs.Close
       Set rs = Nothing
       cn.Close
       Set cn = Nothing
   End Sub

Exercice-1 correspond au champ de ma base de donnée dans lequel j'aimerais transferer la donnée
Lorsque je l'exécute je n'ai aucun message d'erreur, rien du tout mais mes données ne se sont pas transférées.

Merci d'avance