Gestion des doublons dans l'import de fichier excel dans access [Résolu]

[Nitromard]

Bonjour à tous,

J'ai un problème de doublons lorsque j'extrais des données d'excel vers access. Le programme m'affiche l'erreur :

The changes you requested to the table were not successful because they would create duplicate values in the index, primary key, or relationship. Chqnge the data in the field or fields that contain duplicate data, remove the index, or redefine the index to permit duplicate entries and try again.


En fait j'ai dans ma table 2 clés primaires, mais lorsque j'ai un doublon que j'essaye d'importer, le programme me met cette erreur et ne continue pas sur les autres fichiers excel.
(pour moi un doublon est une ligne qui a les mm 2 clés primaires qu'une qui est déjà dans la table)
J'aimerais pouvoir éviter d'afficher cette erreur à chaque fois qu'il y a un doublon et ainsi continuer le programme, tout en évitant de me mettre le doublon dans la table.

Voici mon 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
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
Sub tranfertFeuilleClasseursFermes_VersAccess()
Dim Cn As New ADODB.Connection
Dim oProdRS As New ADODB.Recordset, oRS As ADODB.Recordset
Dim oConn As ADODB.Connection
Dim j As Integer
Dim Fichier As String, Repertoire As String
 
'------------------------------------------------------
'Connection à la Base Access
Set oConn = CurrentProject.Connection

'les données seront placés dans Table1
Set oRS = New ADODB.Recordset
oRS.Open "Select * from Table1", oConn, adOpenKeyset, adLockOptimistic
'------------------------------------------------------
 
'Boucle sur les classeurs Excel du répertoire cible
Repertoire = "C:\Users\qdeutschle\Desktop\Work\Données\Folder"
Fichier = Dir(Repertoire & "\*.xls")

Do While Fichier <> ""
    'Connection au classeur Excel
    Cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
    "Data Source=" & Repertoire & "\" & Fichier & ";" & _
    "Extended Properties=""Excel 8.0;"""
    
    'requête pour extraire les données de la Feuil1
    oProdRS.Open "SELECT * FROM [Sheet4$]", Cn, adOpenStatic
    
    ' --- Transfert des données dans la base ---
    Do While Not (oProdRS.EOF)
        oRS.AddNew
            For j = 0 To oRS.Fields.Count - 1
            oRS.Fields(j) = oProdRS.Fields(j).Value
            Next j
        oRS.Update       
oProdRS.MoveNext
    Loop
    '-------------------------------------------
    
    oProdRS.Close
    'Fermeture de la connection au classeur Excel
    Cn.Close
Fichier = Dir
Loop

oRS.Close
Set oRS = Nothing
'Fermeture de la connection Access
oConn.Close
Set oConn = Nothing
End Sub

(j'ai mis en rouge ce que le débugger me surligne lorsqu'il m'affiche l'erreur)

Merci d'avance pour votre aide.

[jpcheck]

salut,

ne serait-ce pas plus simple de faire un import complet du fichier excel, puis d'executer une requete au lieu de faire du ligne a ligne dans ton cas ?

[Nitromard]

Non je ne pense pas, j'ai juste donné un programme simplifié de celui avec lequel je vais travailler, car en fait je dois aussi et surtout importer des données de feuilles excel vers des tables déjà existante et actualiser ces tables, et en créer de nouvelles lorsque elle n'existe pas pour le nom du fichier.

Pour le moment mon seul problème c'est les doublons...
J'avais essayé avec On Error Goto, mais je ne savais pas trop où le mettre et j'avais quand même des erreurs de doublons.

J'ai aussi essayé avec On Error Resume Next, le problème est qu'il me met quand même les doublons dans les tables.

[Nitromard]

Je n'ai toujours pas d'idée d mon côté pour éviter les doublons, quelqu'un aurait une idée?
Existerait-il une fonction qui permette de sauter une action dans le code lorsqu'il y a un message d'erreur?
Le problème avec On error goto c'est que j'ai une erreur à la base sur :

Code :

oRS.Update

Et quand je le met autour de cette ligne pour passer à la valeur suivante de ma feuille excel à extraire, il me met l'erreur de doublons sur le :

Code :

oRS.AddNew

Et là je reste bloqué...

[User]

Salut,

Peut-être en testant si la clé est présente dans la table destination:

En supposant que ta clé est composée des 2 premiers champs numériques: "Champ1" et "Champ2"

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
 
Do While Not (oProdRS.EOF)
 
       if IsNull(DLookUp("Champ1",TableName,"Champ1=" & oProdRS.Fields(0).Value & " and Champ2=" & oProdRS.Fields(1).Value)) then
 
          oRS.AddNew                 
 
          For j = 0 To oRS.Fields.Count - 1
              oRS.Fields(j) = oProdRS.Fields(j).Value
          Next j
 
          oRS.Update
 
       end if 
 
 oProdRS.MoveNext
 Loop

A+

[Godzestla]

Bonjour,

je pense comme Jpcheck.

Il est nettement plus simple et plus fiable d'importer complètement le fichier excel vers une table de travail puis via une requete tester pour chaque record si il a doublon ou pas avant de l'utiliser pour mettre à jour la véritable access.

[Nitromard]

Bonjour,

User, j'ai tenté ta méthode :

Code :

1
2
3
4
5
6
7
8
9
10
11
Do While Not (oProdRS.EOF)
            If IsNull(DLookup("Numero", TableName, "Numero=" & oProdRS.Fields(0).Value & " and Date_Nav=" & Format(oProdRS.Fields(1), "dd/mm/yyyy"))) Then
 
                oRS.AddNew
                For j = 0 To oRS.Fields.Count - 1
                    oRS.Fields(j) = oProdRS.Fields(j).Value
                Next j
                oRS.Update
            End If
                oProdRS.MoveNext
            Loop

(Juste une précision, le programme que je vous ai montré n'est pas le programme que j'utilise mais c'est la base de mon programme, je vous met le programme complet si cela vous intéresse)

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
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
Function ExtractExcel()
 
Dim Cn As New ADODB.Connection
Dim oProdRS As New ADODB.Recordset, oRS As ADODB.Recordset
Dim oConn As ADODB.Connection
Dim j As Integer
Dim Fichier As String, Repertoire As String
Dim Tbl As TableDef
Dim Fich As String
Dim TableExiste As Boolean
Dim TableName As String
Dim RepDest As String
Dim oFSO As Scripting.FileSystemObject
Dim oFld As Scripting.Folder
 
'Instanciation du FSO
Set oFSO = New Scripting.FileSystemObject
 
'On vérifie si le répertoire de destination n'existe pas déjà
If Dir("C:\Users\qdeutschle\Desktop\Demo" & "\" & Format(Now, "dd-mmm-yyyy"), vbDirectory) = "" Then
    'Crée le repertoire
    Set oFld = oFSO.CreateFolder("C:\Users\qdeutschle\Desktop\Demo" & "\" & Format(Now, "dd-mmm-yyyy"))
    RepDest = "C:\Users\qdeutschle\Desktop\Demo" & "\" & Format(Now, "dd-mmm-yyyy")
Else
    RepDest = "C:\Users\qdeutschle\Desktop\Demo" & "\" & Format(Now, "dd-mmm-yyyy")
End If
 
'Boucle sur les classeurs Excel du répertoire cible
Repertoire = "C:\Users\qdeutschle\Desktop\Demo\Test"
Fichier = Dir(Repertoire & "\*.xls")
 
'Connection à la Base Access
Set oConn = CurrentProject.Connection
Set oRS = New ADODB.Recordset
 
'S'il y a une erreur, on la passe, mais l'action se fait quand même
On Error Resume Next
 
 
Do While Fichier <> ""
    'Connection au classeur Excel
    Cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
    "Data Source=" & Repertoire & "\" & Fichier & ";" & _
    "Extended Properties=""Excel 8.0;"""
 
    TableExiste = False
 
    'Parcours du nom des tables de la base pour le fichier
    For Each Tbl In CurrentDb.TableDefs
        Fich = Left(Fichier, Len(Fichier) - 4)
        TableName = Tbl.Name
 
        If Fich = TableName Then
            TableExiste = True
            'requête pour extraire les données de la Feuil1
            oProdRS.Open "SELECT * FROM [PortFolio$]", Cn, adOpenStatic
            oRS.Open "Select * from " & TableName & "", oConn, adOpenKeyset, adLockOptimistic
 
            ' --- Transfert des données dans la base ---
            Do While Not (oProdRS.EOF)
            If IsNull(DLookup("Numero", TableName, "Numero=" & oProdRS.Fields(0).Value & " and Date_Nav=" & Format(oProdRS.Fields(1), "dd/mm/yyyy"))) Then
 
                oRS.AddNew
                For j = 0 To oRS.Fields.Count - 1
                    oRS.Fields(j) = oProdRS.Fields(j).Value
                Next j
                oRS.Update
            End If
                oProdRS.MoveNext
            Loop
        oProdRS.Close
        oRS.Close
 
        ElseIf Left(Fichier, 3) = "NAV" Then
            TableExiste = True
            'requête pour extraire les données de la Feuil1
            oProdRS.Open "SELECT * FROM [NAV$]", Cn, adOpenStatic
            oRS.Open "Select * from  HISTO_FUND ", oConn, adOpenKeyset, adLockOptimistic
 
            ' --- Transfert des données dans la base ---
            Do While Not (oProdRS.EOF)
                oRS.AddNew
                    For j = 0 To oRS.Fields.Count - 1
                    oRS.Fields(j) = oProdRS.Fields(j).Value
                    Next j
                oRS.Update
                oProdRS.MoveNext
            Loop
        oProdRS.Close
        oRS.Close
        End If
    Next Tbl
 
    'Si pas de table du nom du fichier, créer une table
    If TableExiste = False Then
        CurrentDb.Execute "SELECT * INTO [" & Fich & "] FROM TableSource"
        CurrentDb.Execute "CREATE INDEX NewIndex ON " & Fich & "(Numero, Date_Nav) WITH PRIMARY"
 
        'requête pour extraire les données de la Feuil1
        oProdRS.Open "SELECT * FROM [PortFolio$]", Cn, adOpenStatic
        oRS.Open "Select * from " & Fich & "", oConn, adOpenKeyset, adLockOptimistic
 
        ' --- Transfert des données dans la base ---
        Do While Not (oProdRS.EOF)
            oRS.AddNew
            For j = 0 To oRS.Fields.Count - 1
                oRS.Fields(j) = oProdRS.Fields(j).Value
            Next j
            oRS.Update
            oProdRS.MoveNext
        Loop
        oProdRS.Close
        oRS.Close
    End If
 
    'Fermeture de la connection au classeur Excel
    Cn.Close
    'Déplacer le fichier dans le folder date du jour
    'Si fichier existe déja :
    oFSO.MoveFile Repertoire & "\" & Fichier, RepDest & "\" & Fichier
Fichier = Dir
 
Loop
 
On Error GoTo 0
 
oConn.Close
Set oRS = Nothing
'Fermeture de la connection Access
Set oConn = Nothing
 
End Function

J'ai fait le test avec une table dans laquelle j'ai mis des données et j'ai essayé d'y ajouter des valeurs déja existante et il entre quand mm dans la boucle...et donc me crée la mm erreur qu'au début...(sauf si bien sûr je met le on error resume next)

J'ai alors fait plusieurs autres tests, du genre juste changer la date et ça fonctionne bien, et il ne me crée plus de doublons (il m'avait mis les données de la table 6112 dans la table 0053 mais il ne me le fait plus).

Donc pour l'instant ça à l'air de fonctionner, je vais faire d'autres tests et je vous tiens au courant.

[Nitromard]

Bon j'ai refait des tests, et il y a effectivement un problème...
Alors je vous explique mon programme :
Il prend un fichier xls d'un dossier, regarde s'il existe une table qui porte le mm nom, si c'est le cas, il importe les données sinon il regarde si le mot NAV apparait dans le nom du fichier excel et importe les données dans la table corespondante sinon, il crée une nouvelle table à partir d'une table source qui a la mm structure et importe les données.

J'ai fait un test avec 2 fichiers excel différents 6112.xls et 5030.xls, les 2 portent les numéros 1 à 640 en 1ère clé primaire, par contre l'un porte les dates 30/12/2010 en 2nde clé primaire et l'autre les dates 01/01/2005.(il y a donc répétition 640 fois de ces dates)
Je les importe une fois en table, aucun problème tout va bien.
Ensuite je refais le test avec les mm fichiers excel sans rien y modifier et le problème est que :
Il met les données du fichier excel 6112 dans la table 5030... Du coup il n'y a effectivement pas de doublons mais il s'est trompé de table.
J'ai utilisé le débugger pour voir les étapes du programme et en fait il fait tout comme il faut, il trouve bien la bonne table 6112 pour le bon fichier excel 6112 et idem pour 5030, mais il importe quand mm les données de 6112 mais dans la table 5030...

Voila pour résumer ^^. Y aurait-il un problème quelque part ?

(Je pense que ça vient du faire qu'il lise quand mm les données et du coup il faut bien qu'il les enregistre quelque part, alors il les met dans une autre table que celle prévue...mais comment modifier cela?)

(en fait j'ai dû faire une faute dans ma condition if, parce qu'apparemment la valeur de isnull(dlookup(...)) est toujours true. Donc il ne trouve jamais la condition que je lui donne)

[Godzestla]

Rebonjour,

J'ai utilisé le débugger pour voir les étapes du programme et en fait il fait tout comme il faut, il trouve bien la bonne table 6112 pour le bon fichier excel 6112 et idem pour 5030, mais il importe quand mm les données de 6112 mais dans la table 5030...

Tu dois pouvoir mettre le doigt la dessus via le debugger.

C'est vraisemblablement un problème de logique de programmation (IF Then Else mal positionné), un variable mal réinitialisée ou qqchose du genre.

Bon debug.

[Nitromard]

Bon, je me suis amusé avec le débugger mais je ne trouve vraiment rien...
Le seul problème que j'ai vu c'est dans la définiton de :

Code :

If IsNull(DLookup("Numero", TableName, "Numero=" & oProdRS.Fields(0).Value & " and Date_Nav=" & Format(oProdRS.Fields(1), "dd/mm/yyyy"))) Then

En fait, j'ai mis le résultat du DLookup dans une variable pour voir lors du débugger quelle valeur prenait celui-ci, mais apparemment, mm quand les valeurs sont présentes dans ma table, il me donne la valeur "". (j'ai vérifié s'il me trouvait bien les bonnes valeurs dans Numero et Date_Nav cad ici 1 et 31/12/2010, ensuite 2 et 31/12/2010,...)

Donc je pense qu'il est mal défini...
Ensuite pour le problème de la copie des tables dans une mauvaise...Aucune idée, j'ai essayé de déplacer le :

Code :

Set oRS = New ADODB.Recordset

Pour voir si c'était un problème d'enregistrement ADO mais ça n'a rien changé.
J'essaye d'autres test, mais je pense que si j'ai déjà la condition IF qui fonctionne, j'aurais sans doute plus ce problème ^^.

(Au fait, c'est normal que lors de mon débugger j'ai des noms de table qui n'existe pas dans ma base de données? Je pensais que les éléments de TableDefs n'était que les tables qui apparaissaient, y aurait-il d'autres éléments dans cet ensemble?)

[Nitromard]

Bon j'ai changer de place le :

Code :

Set oRS = New ADODB.Recordset

Et j'en ai mis un dans chacun de mes 3 possibilités de table, cad créer une table, lire le nom par rapport au nom de la table et si le fichier excel contient NAV dans le nom.

Et j'ai refait plusieurs tests (sans la condition If proposée par User)...
Et apparemment cela fonctionne...
Donc apparemment ça doit être bon ^^, je reviendrais vers vous si jamais j'ai encore un problème, en attendant je mets cette discussion en résolue ^^!

En tout cas, merci à vous tous pour vos réponses, j'en apprends un peu plus à chaque fois !

[Godzestla]

Bonjour,

chouette que cela fonctionne.

Pour ceci,

(Au fait, c'est normal que lors de mon débugger j'ai des noms de table qui n'existe pas dans ma base de données? Je pensais que les éléments de TableDefs n'était que les tables qui apparaissaient, y aurait-il d'autres éléments dans cet ensemble?)

oui, il y aussi des tables systèmes.

Au cas où cela t'intéresse, j'utilise le code ci-dessous pour afficher la liste des objets (non systèmes) de ma DB dans un contrôle de formulaire.
Je choisis le type via un contrôle et j'obtiens la liste triée en dessous (cela me sert à de l'export pour de la maintenance).

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
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
Private Sub Lsttypes_Click()
'On Error GoTo Lsttypes_Click_Error
 
    Dim objAO As AccessObject
    Dim objCP As Object
    Dim strValues As String
    Dim Col As Object
    Dim tblvalues() As String
    Dim nbr_values  As Long
    Dim idx         As Long
    Dim Swap        As String
 
    strValues = ""
    Lstobjects.RowSource = strValues
 
 
    If Not IsNull(Lsttypes) Then
 
    Select Case (Lsttypes)
            Case "acTable" 'Tables
                Set objCP = Application.CurrentData
                Set Col = objCP.AllTables
            Case "acQuery" 'Queries
                Set objCP = Application.CurrentData
                Set Col = objCP.AllQueries
            Case "acDiagram" 'Diagram
                Set objCP = Application.CurrentData
                Set Col = objCP.AllDatabaseDiagrams
            Case "acStoredProcedure" 'Stored procedures
                Set objCP = Application.CurrentData
                Set Col = objCP.AllStoredProcedures
            Case "acForm"   'Forms
                Set objCP = Application.CurrentProject
                Set Col = objCP.AllForms
            Case "acMacro"  'Macros
                Set objCP = Application.CurrentProject
                Set Col = objCP.AllMacros
            Case "acModule" 'Modules
                Set objCP = Application.CurrentProject
                Set Col = objCP.AllModules
            Case "acReport" 'Reports
                Set objCP = Application.CurrentProject
                Set Col = objCP.AllReports
            Case Else
                GoTo Lsttypes_Click_Exit
    End Select
 
    nbr_values = 0
    ReDim tblvalues(1)
    For Each objAO In Col
       nbr_values = nbr_values + 1
       ReDim Preserve tblvalues(nbr_values)
       tblvalues(nbr_values) = objAO.Name
    Next objAO
 
    'Sort table
    For idx = 1 To nbr_values
       For idy = idx + 1 To nbr_values
          If tblvalues(idx) > tblvalues(idy) Then
             'Swap
             Swap = tblvalues(idx)
             tblvalues(idx) = tblvalues(idy)
             tblvalues(idy) = Swap
          End If
       Next idy
    Next idx
 
    'Save Sorted values in string
    strValues = ""
    For idx = 1 To nbr_values
        strValues = strValues & Trim(tblvalues(idx)) & ";"
    Next idx
 
    Lstobjects.RowSource = strValues
 End If
 
Lsttypes_Click_Exit:
   Exit Sub
Lsttypes_Click_Error:
 If err.Number = 2467 Then
   MsgBox ("No objects available for such a Type")
  Else
   MsgBox err.Number & " " & err.Description
 
End If
 
Resume Lsttypes_Click_Exit
 
End Sub