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
| Sub ImportAllFiles()
'Supprimer enreg table T_Import_Brut
DoCmd.RunSQL "DELETE FROM TImportTable1"
DoCmd.RunSQL "DELETE FROM TImportTable2"
DoCmd.RunSQL "DELETE FROM TImportTable3"
DoCmd.RunSQL "DELETE FROM TImportTable4"
DoCmd.RunSQL "DELETE FROM TImportTable5"
DoCmd.RunSQL "DELETE FROM TBTable6"
Dim strPathToFiles As String
Dim xlAppl As Excel.Application
Dim wb As Excel.Workbook
Dim onglet As String
Dim ws As Excel.Worksheet
Dim Repertoire As String, Fichier As String
Dim ExcelCreated As Boolean
Repertoire = "C:\documents and Settings\Import\"
Fichier = Dir(Repertoire & "*.xls")
Set xlAppl = Nothing
ExcelCreated = False
On Error Resume Next
Set xlAppl = GetObject(, "Excel.Application")
On Error GoTo 0
If xlAppl Is Nothing Then
Set xlAppl = CreateObject("Excel.Application")
ExcelCreated = True
End If
Do While Fichier <> ""
strPathToFiles = Repertoire & Fichier
Set wb = xlAppl.Workbooks.Open(strPathToFiles)
For Each ws In wb.Worksheets
If ws.Visible = True Then
onglet = ws.Name
If onglet = "TestIndicateurs" Then
' transfert vers table T_Import_Brut
DoCmd.TransferSpreadsheet acImport, 8, "TImportTable1", _
strPathToFiles, False, onglet & "!H1:L201"
DoCmd.TransferSpreadsheet acImport, 8, "TImportTable2", _
strPathToFiles, False, onglet & "!H202:L291"
DoCmd.TransferSpreadsheet acImport, 8, "TImportTable3", _
strPathToFiles, False, onglet & "!H292:L328"
DoCmd.TransferSpreadsheet acImport, 8, "TImportTable4", _
strPathToFiles, False, onglet & "!H338:M344"
DoCmd.TransferSpreadsheet acImport, 8, "TImportTable5", _
strPathToFiles, False, onglet & "!H345:L352"
ElseIf onglet = "TransposeB" Then
' transfert vers table T_Import_IG
DoCmd.TransferSpreadsheet acImport, 8, "TBTable6", _
strPathToFiles, False, onglet & "!A1:F"
End If
End If
Next ws
wb.Close
Set wb = Nothing
Fichier = Dir
Loop
If ExcelCreated Then xlAppl.Quit
Set xlAppl = Nothing
End Sub |
Partager