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
|
Sub tranfertFeuilleClasseursFermes_VersAccess1()
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
'Boucle sur les classeurs Excel du répertoire cible
Repertoire = "C:\Users\name\Desktop\Work\Données\Folder"
Fichier = Dir(Repertoire & "\*.xls")
'Connection à la Base Access
Set oConn = CurrentProject.Connection
Set oRS = New ADODB.Recordset
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 [Sheet1$]", Cn, adOpenStatic
oRS.Open "Select * from " & TableName & "", 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
ElseIf Left(Fichier, 3) = "NAV" Then
TableExiste = True
'requête pour extraire les données de la Feuil1
oProdRS.Open "SELECT * FROM [Sheet1$]", 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 6112Bis;"
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 [Sheet1$]", 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
Fichier = Dir
Loop
oConn.Close
Set oRS = Nothing
'Fermeture de la connection Access
Set oConn = Nothing
End Sub |
Partager