Discussion :

[Crachover]

Bonjour,

J'aimerais pouvoir automatiser l'importation de certaines tables avec données externes Access, car cela me prend un temps de malade, je m'explique...

Ce que j'ai pour le moment et qui fonctionne très bien...

Une base de données principale contenant :

• différentes tables (Table_Heures supplémentaires_LBSP, Table_prestations etc...)
• deux requêtes de fusion qui prennent les données des tables "importées d'une base de données secondaire" Heures supplémentaires et Table_prestations_AS et ajoute les données aux tables Table_Heures supplémentaires_LBSP, Table_prestations
• ces deux tables Heures supplémentaires et Table_prestations_AS sont importées via l'option Données externes / Access et ensuite importer les tables.
• je termine par supprimer les deux tables Heures supplémentaires et Table_prestations_AS.

Tout cela se fait via une macro (sauf l'importation des deux tables !)

Mon problème est que toute les semaines, j'ai plus de 30 bases de données secondaires à importer, vous imaginez donc le temps passer à ça...

J'aimerais pouvoir si c'est possible

deux solutions :

1. serait de définir via une boîte de dialogue un répertoire contenant tous les fichiers secondaires à importer
2. pouvoir définir manuellement toujours via une boîte de dialogue les fichiers secondaires à importer

et ensuite
faire une espèce de routine qui prendrait le 1er fichier secondaire, importerait les deux tables, lancerait la macro, avec les fusions etc... et recommencerait jusqu'au dernier fichier secondaire sélectionné ou du répertoire sélectionné...

le top serait aussi d'avoir un compte rendu, style fichier texte (rendu-22022021.txt) qui se sauverait dans le répertoire actif des fusions et qui se lancerait aussi à la fin des fusions si problèmes... le rêve quoi...

• fichier Marie.accdb - OK
• fichier Luc.accdb - OK
• fichier Valentine.accdb - TABLE Heures supplémentaires non trouvée !
• fichier Alain.accdb - OK
• fichier Vincent.accdb - TABLE Table_prestations_AS non trouvée!
• fichier Cédric.accdb - TABLES NON TROUVEES !
• fichier Natacha.accdb - OK
• ...

Pourriez-vous m'aider ??

Merci d'avance

[Zekraoui_Jakani]

Vous pouvez créer une boucle qui fait appel aux instructions d'import de toutes les feuilles (ayant la même structure), comme par exemple dans:
https://access-excel.tips/access-vba...erspreadsheet/

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

DoCmd.TransferSpreadsheet(TransferType, SpreadsheetType, TableName, FileName, HasFieldNames, Range)

[Crachover]

Bonjour,

Merci pour votre réponse

Donc si je comprends bien, je dois passer par un fichier Excel pour importer mes données Access vers Access... Pourquoi pas, mais j'ai encore le problème de la boucle et des fichiers...

Comme expliqué, ma macro fonctionne très bien, ce qu'il me faudrait c'est une méthode qui :

1. listerait les fichiers *.accdb ou les fichiers sélectionnés d'une répertoire
2. garderait en mémoire les url des fichiers
3. ferait une boucle du nombre de fichiers
4. prendrait le premier fichier de la liste
5. importerait les deux tables définies (Heures supplémentaires et Table_prestations_AS), avec test si elles n'existent pas...
6. lancerait la macro de fusion (fusion et suppression des deux tables pour la suite...)
7. alimenterait un fichier texte avec le nom du fichier 1 et le statut OK ou pas...
8. prendrait le fichier 2 si il existe ect...
9. a la fin de la boucle, affichage du fichier texte si il y a au moins 1 problème...

Belle journée

[Zekraoui_Jakani]

Désolé; j'ai lu trop vite.
Si c'est un lien entre les BD dans Access, autant lier les tables et non les importer: cela se fait via "Import" puis choisir l'option "Link"

[Crachover]

Pas possible...

Tous les fichiers *.accdb à importer contiennent les deux mêmes tables... et en plus le nombre de fichiers peut évoluer...

Il me faudrait alors une macro par fichier et je devrais en ajouter ou en supprimer presque toutes les semaines, donc plus rien d'automatique

Bonne journée et merci pour l'attention porter à mon post

[Crachover]

Je bloque déjà sur comment lister les fichiers du répertoire et de ces sous-répertoires...

MODULE

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Option Compare Database
' ---
' CONSTANTES
' ---
' Nom de la table et du champ
Public Const TABLE_FICHIERS = "tbl Fichiers"
Public Const CHAMP_FICHIER = "Fichier"
 
' ---
' LISTE DU CONTENU D'UN DOSSIER VERS UNE TABLE
' ---
'
Sub ListerFichiersRec( _
    ByVal strDossier As String, _
    Optional ByVal strExtension As String = "*.*", _
    Optional blnViderTable As Boolean = False, _
    Optional blnCheminComplet As Boolean = True)
 
    ' Variables
    Dim rst As DAO.Recordset
 
    ' Vérifier que le dossier existe bien
    strDossier = AddBackslash(strDossier)
    If Dir(strDossier, vbDirectory) = "" Then
        MsgBox "Dossier introuvable !", vbExclamation
        Exit Sub
    End If
 
    ' Vider la table si nécessaire
    If blnViderTable Then
      CurrentDb.Execute "DELETE FROM [" & TABLE_FICHIERS & "];"
    End If
 
    ' Ouvrir la table
    Set rst = CurrentDb.OpenRecordset(TABLE_FICHIERS, dbOpenDynaset)
 
    ' Déclencher le parcours récursif des fichiers
    ListerFichiersRecDetail rst, strDossier, strExtension, blnCheminComplet
 
    ' On libère les ressources
    rst.Close
    Set rst = Nothing
End Sub
 
' ---
' PARCOURS RECURSIF DE DOSSIERS
' ---
'
Sub ListerFichiersRecDetail( _
    rst As DAO.Recordset, _
    ByVal strDossier As String, _
    Optional ByVal strExtension As String = "*.*", _
    Optional blnCheminComplet As Boolean = True)
 
    ' Quelques variables...
    Dim strFichier As String
    Dim varSousDossiers As Variant
    Dim intI As Integer
 
    ' Lister tous les fichiers du dossier
    DoEvents
    strDossier = AddBackslash(strDossier)
    strFichier = Dir(strDossier & strExtension, vbNormal)
    While strFichier <> ""
        ' Stocker le nom du fichier dans la table
        rst.AddNew
        rst(CHAMP_FICHIER) = IIf(blnCheminComplet, _
          strDossier & strFichier, _
          strFichier)
        rst.Update
 
        ' Lire le fichier suivant
        strFichier = Dir
    Wend
 
    ' Trouver les sous-dossiers éventuels
    varSousDossiers = ListerSousDossiers(strDossier)
 
    ' S'il y a des sous-dossiers, les parcourir aussi récursivement
    If (UBound(varSousDossiers) > 0) Then
        ' Traiter les sous-dossiers
        For intI = 1 To UBound(varSousDossiers)
          ListerFichiersRecDetail rst, varSousDossiers(intI), strExtension, blnCheminComplet
        Next
    End If
End Sub

CODE DE LANCEMENT

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
ListerFichiersRec "C:\Users\Propriétaire\Desktop\Prestations\01Janvier\", "*.mdb", True, True
ListerFichiersRec "C:\Users\Propriétaire\Desktop\Prestations\01Janvier\", "*.accdb", True
    MsgBox "Terminé !", vbInformation

...

[Thumb down]

Bonjour,

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Option Compare Database
Sub test()
    With CreateObject("Scripting.FileSystemObject").GetFolder("C:\Myrep\")  'Liste les fichiers du répertoire
        For Each NomFich In .Files
          If UCase(Split(NomFich.Name, ".")(1)) = "MDB" Or Split(NomFich.Name, ".")(1) = "ACCDB" Then
            Importer NomFich.Path
          End If
        Next
    End With
End Sub
Sub Importer(Fichier As String)
On Error Resume Next
CurrentDb.Execute "Drop Table Temp"
On Error GoTo 0
CurrentDb.Execute "SELECT * Into Temp FROM ATRAITER in '" & Fichier & "';"
End Sub

[Crachover]

Bonjour,

Merci pour votre réponse, mais cela ne fonctionne pas non plus... j'ai bien créé la table ATRAITER avec un champ [Fichier]

Mais j'ai encore cette fenêtre qui apparait (la même pour tout mes tests...)

[Thumb down]

montre le code que tu a fait et la ligne ou ce trouve l'erreur!

Tous les fichiers *.accdb à importer contiennent les deux mêmes tables...

il n'y a pas de table à créer n'y de champ fichier!
ATRAITER c'était juste un exemple !

Fichier c'est le paramètre de la procédure import!

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
Sub Importer(Fichier As String)
On Error Resume Next
CurrentDb.Execute "Drop Table Temp"
CurrentDb.Execute "Drop Table Temp2"
On Error GoTo 0
CurrentDb.Execute "SELECT * Into Temp FROM Table1 in '" & Fichier & "';"
CurrentDb.Execute "SELECT * Into Temp2 FROM Table2 in '" & Fichier & "';"
End Sub

[Crachover]

OK... ton code est pour lister ET importer les deux tables c'est ça ?...

Sorry, mais juste avant, la discussion était sur comment lister les fichiers *.accbd et *.mdb présents dans le répertoire et sous-répertoire pour après pouvoir un par un utiliser un code pour importer les deux tables et ensuite lancer la macro

1. lister les fichiers *.accdb ou les fichiers sélectionnés d'une répertoire et sous-répertoires
2. sauver dans une table les url des fichiers *.accdb et *.mdb
3. faire une boucle du nombre de fichiers
4. prendre le premier fichier de la liste
5. importer les deux tables définies (Heures supplémentaires et Table_prestations_AS), avec test si elles n'existent pas...
6. lancer la macro de fusion (fusion et suppression des deux tables pour la suite...)
7. alimenter un fichier texte avec le nom du fichier 1 et le statut OK ou pas...
8. prendre le fichier 2 si il existe ect...
9. a la fin de la boucle, affichage du fichier texte si il y a au moins 1 problème...

Donc si j'ai bien compris... ce code prend un par un les fichiers MBD et ACCDB du répertoire et sous-répertoires, importe les deux tables des fichiers trouvés Heures supplémentaires et Table_prestations_AS et après il faut que je lance ma marco... ou dois-je placer le code de lancement ?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Option Compare Database
Sub test()
    With CreateObject("Scripting.FileSystemObject").GetFolder("C:\Users\Propriétaire\Desktop\Prestations 2020\01Janvier\")  'Liste les fichiers du répertoire
        For Each NomFich In .Files
          If UCase(Split(NomFich.Name, ".")(1)) = "MDB" Or Split(NomFich.Name, ".")(1) = "ACCDB" Then
            Importer NomFich.Path
          End If
        Next
    End With
End Sub
Sub Importer(Fichier As String)
On Error Resume Next
CurrentDb.Execute "Heures supplémentaires"
CurrentDb.Execute "Table_prestations_AS"
On Error GoTo 0
CurrentDb.Execute "SELECT * Into Temp FROM ATRAITER in '" & Fichier & "';"
CurrentDb.Execute "SELECT * Into Temp FROM ATRAITER in '" & Fichier & "';"

Code pour lancer la macro [Fusion des 2 tables de l'AS]

Il me faudrait aussi la création d'un fichier texte ou d'une table avec les erreurs, style manque un des fichiers... il devrait se lancer à la fin si il n'est pas vide... je sais cela fait beaucoup ;-)

End Sub

Je devrais donc après lancement avoir x fois (nombre de fichier dans le répertoire) les deux tables importées ? C'est ça ? Mais toujours la même fenêtre d'erreur...

[Thumb down]

comprennes bien qu'il faut travailler sur tes tables ce que je donnes c'est des indications!

je ne me suis pas intéressé aux sous répertoire!

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Option Compare Database
Sub test()
    With CreateObject("Scripting.FileSystemObject").GetFolder("C:\Users\Propriétaire\Desktop\Prestations 2020\01Janvier\")  'Liste les fichiers du répertoire
        For Each NomFich In .Files
          If UCase(Split(NomFich.Name, ".")(1)) = "MDB" Or Split(NomFich.Name, ".")(1) = "ACCDB" Then
           If Importer(NomFich.Path) Then Application.Run "MyMacro"
 
          End If
        Next
    End With
End Sub
Function Importer(Fichier As String) As Boolean
Dim IfErr As Boolean
On Error Resume Next
CurrentDb.Execute "DROP Table [Heures supplémentaires]"
CurrentDb.Execute "DROP [Table_prestations_AS]"
Err.Clear
 
 
CurrentDb.Execute "SELECT * Into [Heures supplémentaires] FROM [Heures supplémentaires] in '" & Fichier & "';"
If Err Then IfErr = True
AppendTxt CurDir & "\Fichier.Log", Now & vbCrLf & Fichier & vbCrLf & "Table := [Heures supplémentaires]" & vbCrLf & "Resulta ok := " & (Not CBool(Err)) & vbCrLf & Err.Description & vbCrLf & String(50, "*") & vbCrLf
CurrentDb.Execute "SELECT * Into  [Table_prestations_AS] FROM  [Table_prestations_AS] in '" & Fichier & "';"
If Err Then IfErr = True
AppendTxt CurDir & "\Fichier.Log", Now & vbCrLf & Fichier & vbCrLf & "Table := [Table_prestations_AS]" & vbCrLf & "Resulta ok := " & (Not CBool(Err)) & vbCrLf & Err.Description & vbCrLf & String(50, "*") & vbCrLf
On Error GoTo 0
Importer = Not IfErr
End Function
Sub MyMacro()
MsgBox "TOTO"
End Sub
Function AppendTxt(sFile, sText)
Dim FSO, NewFichier
Set FSO = CreateObject("Scripting.FileSystemObject")
Set NewFichier = FSO.OpenTextFile(sFile, Array(2, 8)(Abs(FSO.FileExists(sFile))), True)
NewFichier.Write sText
NewFichier.Close
Set NewFichier = Nothing
Set FSO = Nothing
End Function

[Crachover]

Et bien nous avançons

Le code fonctionne en partie...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub test()
    With CreateObject("Scripting.FileSystemObject").GetFolder("C:\Users\Propriétaire\Desktop\Prestations 2020\01Janvier\")  'Liste les fichiers du répertoire
        For Each NomFich In .Files
          If UCase(Split(NomFich.Name, ".")(1)) = "MDB" Or Split(NomFich.Name, ".")(1) = "ACCDB" Then
           If Importer(NomFich.Path) Then DoCmd.RunMacro "MyMacro", 0
 
          End If
        Next
    End With
End Sub
Function Importer(Fichier As String) As Boolean
Dim IfErr As Boolean
On Error Resume Next
CurrentDb.Execute "DROP Table [Heures supplémentaires]"
CurrentDb.Execute "DROP [Table_prestations_AS]"
Err.Clear
 
 
CurrentDb.Execute "SELECT * Into [Heures supplémentaires] FROM [Heures supplémentaires] in '" & Fichier & "';"
If Err Then IfErr = True
AppendTxt CurDir & "Fichier.Log", Now & vbCrLf & Fichier & vbCrLf & "Table := [Heures supplémentaires]" & vbCrLf & "Résultat ok := " & (Not CBool(Err)) & vbCrLf & Err.Description & vbCrLf & String(50, "*") & vbCrLf
CurrentDb.Execute "SELECT * Into  [Table_prestations_AS] FROM  [Table_prestations_AS] in '" & Fichier & "';"
If Err Then IfErr = True
AppendTxt CurDir & "Fichier.Log", Now & vbCrLf & Fichier & vbCrLf & "Table := [Table_prestations_AS]" & vbCrLf & "Résultat ok := " & (Not CBool(Err)) & vbCrLf & Err.Description & vbCrLf & String(50, "*") & vbCrLf
On Error GoTo 0
Importer = Not IfErr
End Function
Sub MyMacro()
MsgBox "TOTO"
End Sub
Function AppendTxt(sFile, sText)
Dim FSO, NewFichier
Set FSO = CreateObject("Scripting.FileSystemObject")
Set NewFichier = FSO.OpenTextFile(sFile, Array(2, 8)(Abs(FSO.FileExists(sFile))), True)
NewFichier.Write sText
NewFichier.Close
Set NewFichier = Nothing
Set FSO = Nothing
End Function
 
Private Sub Commande4_Click()
Call test
End Sub
 
Private Sub Commande5_Click()
MsgBox ("COOL")
End Sub

• Lorsque je clique sur le bouton, cela semble importer les deux tables du premier fichier, mais elles n'apparaissent pas... je dois redémarrer le fichier pour les faire apparaitre. maintenant ce n'est pas grave, je peux laisser les deux tables, de toute façon elles semble se remplacer... En théorie il devrait y avoir une Macro qui affiche un message après chaque import, mais rien...
• Le fichier *.log n'est pas créé

Bonne soirée

[Thumb down]

elles existe mais elles n'apparaisses pas ! elles vont apparaitre mantenant!

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Option Compare Database
Sub test()
    With CreateObject("Scripting.FileSystemObject").GetFolder("C:\Users\Propriétaire\Desktop\Prestations 2020\01Janvier\")  'Liste les fichiers du répertoire
        For Each NomFich In .Files
          If UCase(Split(NomFich.Name, ".")(1)) = "MDB" Or Split(NomFich.Name, ".")(1) = "ACCDB" Then
           If Importer(NomFich.Path) Then Application.Run "MyMacro"
 
          End If
        Next
    End With
End Sub
Function Importer(Fichier As String) As Boolean
Dim IfErr As Boolean
On Error Resume Next
CurrentDb.Execute "DROP Table [Heures supplémentaires]"
CurrentDb.Execute "DROP Table [Table_prestations_AS]"
Err.Clear
 
 
CurrentDb.Execute "SELECT * Into [Heures supplémentaires] FROM [Heures supplémentaires] in '" & Fichier & "';"
If Err Then IfErr = True
AppendTxt CurDir & "\Fichier.Log", Now & vbCrLf & Fichier & vbCrLf & "Table := [Heures supplémentaires]" & vbCrLf & "Resulta ok := " & (Not CBool(Err)) & vbCrLf & Err.Description & vbCrLf & String(50, "*") & vbCrLf
CurrentDb.Execute "SELECT * Into  [Table_prestations_AS] FROM  [Table_prestations_AS] in '" & Fichier & "';"
If Err Then IfErr = True
AppendTxt CurDir & "\Fichier.Log", Now & vbCrLf & Fichier & vbCrLf & "Table := [Table_prestations_AS]" & vbCrLf & "Resulta ok := " & (Not CBool(Err)) & vbCrLf & Err.Description & vbCrLf & String(50, "*") & vbCrLf
On Error GoTo 0
Importer = Not IfErr
Application.RefreshDatabaseWindow
End Function
Sub MyMacro()
MsgBox "TOTO"
End Sub
Function AppendTxt(sFile, sText)
Dim FSO, NewFichier
Set FSO = CreateObject("Scripting.FileSystemObject")
Set NewFichier = FSO.OpenTextFile(sFile, Array(2, 8)(Abs(FSO.FileExists(sFile))), True)
NewFichier.Write sText
NewFichier.Close
Set NewFichier = Nothing
Set FSO = Nothing
End Function

• Le fichier *.log n'est pas créé

par défaut il ce trouve dans mes documents je n'es pas défini un autre emplacement mais dis moi!

En théorie il devrait y avoir une Macro qui affiche un message après chaque import, mais rien...

la macro s'exécute si l'import c'est bien passé et il y avait une erreur l'hors de la suppression de la table [Table_prestations_AS]!

je ne suis pas un grand connaisseur des commande intégrés d'ACCESS! {DoCmd}
j'utilise perso Application.Run "MyMacro"

6.lancer la macro de fusion (fusion et suppression des deux tables pour la suite...)

pour ce qui concerne la macro tu dois exécuter ta macro de Application.Run "fusion"

[Crachover]

Bonjour,

Merci, merci et encore merci

Cela fonctionne très bien

Je dois juste obligatoirement utiliser le code...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

DoCmd.RunMacro "MyMacro", 1

... pour lancer la Macro, avec ton code rien ne se passe.

Encore deux petites choses si c'est possible :

1. serait-il possible de faire apparaitre le fichier *.log dans le répertoire de mon fichier Access contenant le code ?
2. et la dernière, pouvoir importer aussi les sous-répertoires de mon répertoire

Ps : je vais essayer de mettre une boîte de dialogue pour choisir le répertoire contenant les fichiers à importer, ça je devrais y arriver...

Je me suis avancé un peu trop vite...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 Dim fd As FileDialog
  Dim REPCHOISI As String
  ' Créer un objet FileDialog
  Set fd = Application.FileDialog(msoFileDialogFolderPicker)
  ' Titre de la boîte
  fd.Title = "Sélectionnez un dossier..."
 
  ' Afficher la boîte et traiter le résultat
  If fd.Show() Then
    REPCHOISI = fd.SelectedItems(1)
  End If
 
  Set fd = Nothing
 
 
 
    With CreateObject("Scripting.FileSystemObject").GetFolder(REPCHOISI)  'Liste les fichiers du répertoire
        For Each NomFich In .Files
          If UCase(Split(NomFich.Name, ".")(1)) = "MDB" Or Split(NomFich.Name, ".")(1) = "ACCDB" Then
           If Importer(NomFich.Path) Then MsgBox (NomFich.Path): DoCmd.RunMacro "MyMacro", 1
 
          End If
        Next
    End With
    AppendTxt CurDir & "\Fichier.Log", "FIN DE L'IMPORTATION !" & vbCrLf & String(50, "/") & vbCrLf & "" & vbCrLf
End Sub

Encore merci Cela va me faire gagner un temps de malade...

[Thumb down]

Bonjour,

Encore deux petites choses si c'est possible :

1. serait-il possible de faire apparaitre le fichier *.log dans le répertoire de mon fichier Access contenant le code ?
2. et la dernière, pouvoir importer aussi les sous-répertoires de mon répertoire

voila!

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Option Compare Database
Sub test()
Dim Rep
Rep = Rep_Selection
If Rep = False Then Exit Sub
SousRepertoire CStr(Rep) 'Liste les fichiers du répertoire
 MsgBox "Fin"
End Sub
Function Rep_Selection()
Rep_Selection = False
On Error GoTo Fin
Dim Rep As String
 Application.FileDialog(4).Show
 Rep_Selection = Application.FileDialog(4).SelectedItems(1)
Fin:
On Error GoTo 0
End Function
Sub SousRepertoire(Rep As String)
With CreateObject("Scripting.FileSystemObject").GetFolder(Rep)  'Liste les fichiers du répertoire
        For Each SRep In .SubFolders
          SousRepertoire SRep.Path
        Next
        For Each NomFich In .Files
            If UCase(Split(NomFich.Name, ".")(1)) = "MDB" Or Split(NomFich.Name, ".")(1) = "ACCDB" Then
                If Importer(NomFich.Path) Then DoCmd.RunMacro "MyMacro", 1 ' Application.Run "MyMacro"
            End If
        Next
    End With
End Sub
Function Importer(Fichier As String) As Boolean
Dim IfErr As Boolean
On Error Resume Next
CurrentDb.Execute "DROP Table [Heures supplémentaires]"
CurrentDb.Execute "DROP Table [Table_prestations_AS]"
Err.Clear
 
 
CurrentDb.Execute "SELECT * Into [Heures supplémentaires] FROM  [Heures supplémentaires] in '" & Fichier & "';"
If Err Then IfErr = True
AppendTxt CurrentProject.Path & "\Fichier.Log", Now & vbCrLf & Fichier & vbCrLf & "Table := [Heures supplémentaires]" & vbCrLf & "Resulta ok := " & (Not CBool(Err)) & vbCrLf & Err.Description & vbCrLf & String(50, "*") & vbCrLf
CurrentDb.Execute "SELECT * Into  [Table_prestations_AS] FROM  [Table_prestations_AS] in '" & Fichier & "';"
If Err Then IfErr = True
AppendTxt CurrentProject.Path & "\Fichier.Log", Now & vbCrLf & Fichier & vbCrLf & "Table := [Table_prestations_AS]" & vbCrLf & "Resulta ok := " & (Not CBool(Err)) & vbCrLf & Err.Description & vbCrLf & String(50, "*") & vbCrLf
On Error GoTo 0
Importer = Not IfErr
Application.RefreshDatabaseWindow
End Function
Sub MyMacro()
MsgBox "TOTO"
End Sub
Function AppendTxt(sFile, sText)
Dim FSO, NewFichier
Set FSO = CreateObject("Scripting.FileSystemObject")
Set NewFichier = FSO.OpenTextFile(sFile, Array(2, 8)(Abs(FSO.FileExists(sFile))), True)
NewFichier.Write sText
NewFichier.Close
Set NewFichier = Nothing
Set FSO = Nothing
End Function

[Crachover]

Merci

Je n'arrive pas à faire passer la variable "Chemin_Dossiers" vers CreateObject("Scripting.FileSystemObject").GetFolder(Chemin_Dossiers)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Dim BoiteDialogue As FileDialog
Dim Chemin_Dossiers As String
 
 
Set BoiteDialogue = Application.FileDialog(msoFileDialogFolderPicker)
BoiteDialogue.AllowMultiSelect = False
BoiteDialogue.Title = "Sélectionner le dossier"
BoiteDialogue.Show
 
' Vérifier qu'un dossier a été sélectionné
If BoiteDialogue.SelectedItems(1) = "" Then
    MsgBox ("Merci de sélectionner un dossier !")
Else
    ' trouver le chemin du dossier
    Chemin_Dossiers = BoiteDialogue.SelectedItems(1) & "/"
 
    'MsgBox (Chemin_Dossiers)
 
End If
SousRepertoire "Chemin_Dossiers" 'Liste les fichiers du répertoire
 AppendTxt CurrentProject.Path & "\Fichier.Log", "FIN DE L'IMPORTATION !" & vbCrLf & String(50, "/") & vbCrLf & "" & vbCrLf
 MsgBox "Fin des importations"
End Sub
Sub SousRepertoire(Rep As String)
With CreateObject("Scripting.FileSystemObject").GetFolder(Chemin_Dossiers)  'Liste les fichiers du répertoire
        For Each SRep In .SubFolders
          SousRepertoire SRep.Path
        Next
        For Each NomFich In .Files
            If UCase(Split(NomFich.Name, ".")(1)) = "MDB" Or Split(NomFich.Name, ".")(1) = "ACCDB" Then
                If Importer(NomFich.Path) Then DoCmd.RunMacro "MyMacro", 1 ' Application.Run "MyMacro"
            End If
        Next
    End With
 
 
End Sub

Bonne soirée

[tee_grandbois]

bonsoir,

Je n'arrive pas à faire passer la variable "Chemin_Dossiers" vers CreateObject("Scripting.FileSystemObject").GetFolder(Chemin_Dossiers)

si c'est une variable, enlève les guillemets:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

SousRepertoire Chemin_Dossiers 'Liste les fichiers du répertoire

[Thumb down]

elle fonctionne pas ma fonction?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Sub test()
Dim Rep
Rep = Rep_Selection
If Rep = False Then Exit Sub
SousRepertoire CStr(Rep) 'Liste les fichiers du répertoire
 MsgBox "Fin"
End Sub
 
Function Rep_Selection()
Rep_Selection = False
On Error GoTo Fin
With Application.FileDialog(4)
    .Title = "Sélectionner le dossier"
    .Show
    Rep_Selection = .SelectedItems(1)
 End With
Fin:
On Error GoTo 0
End Function

[Crachover]

Punaise... je n'avais pas vu tout le code... ça fonctionne nickel

Merci

[Crachover]

Une toute petite dernière chose,

Le bouton qui lance le code se trouve sur un formulaire, j'aimerais voir le déroulement des importations...

J'ai donc ajouter une zone de texte (Texte7)

Et j'essaye avec un code style...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Texte7.Value = Texte7.Value & Fichier & "Résultat OK" & String(50, "*")

... d'alimenter la zone de texte, cela fonctionne, mais j'ai un problème de retour à la ligne et surtout je n'arrive pas à insérer à la place de "Résultat OK", le texte "Problème !" en cas d'erreurs... Il y a aussi un problème d'affichage, tout s'affiche en une fois pas une ligne à la suite l'une de l'autre après chaque importation

Ce que j'aimerais c'est :

1. Quand le 1er fichier se charge, cela affiche "Chargement du fichier : " + le nom du fichier
2. Juste avant l'importation, cela affiche importation de la table : " + le nom de la table (il y aura ici deux lignes...)
3. Après la macro, cela affiche "Fusion des tables de :" + le nom du fichier + "terminée
4. Affiche "******************************************************"

ensuite les autres fichiers... mais que les lignes apparaissent une par une, pas toute en même temps.

Ps : ce qui est aussi étrange, c'est que le scroll de ma souris ne fonctionne pas dans la zone de texte... ?

Merci d 'avance