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 |
