Discussion :

[totor92290]

Re-bonjour,
J'ai fait le tour sur internet et je n'ai pas trouvé "chaussure à mon pied" !
Je m'explique....
J'importe des fichier excel 1 par 1 et je récupère des informations contenus dans ces fichiers.
Ces fichiers ne contiennent pas de numéro unique (clé)
Donc j'avais une solution pour rentrer cette clé manuellement... mais c'est lourd

Code :

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

1
2
3
'Saisie d'une clé ou date du documentdans deux champs de 2 tables
DoCmd.RunSQL "UPDATE AibToolReg_TEMP_IMPORT_Body SET [F3]= [Fill the key] "
DoCmd.RunSQL "UPDATE AibToolReg_TEMP_IMPORT_Header_Comments SET [F2]= [Fill the key]"

En fait, les fichiers ont un nom unique pour le coup !
Comment faire avec un code pour récupérer le nom de chaque fichier et de l'ajouter à la table comme champ "clé"
J'ai trouvé ça
https://www.developpez.net/forums/d1...r-nom-fichier/

mais c'est incompréhensible pour moi... n'existe t-il pas plus simple (d'autan que dans cet exemple il s'agit de code derrière un bouton et plusieurs actions complexes).

Mon code :
1-Activation Excel
2-Création des tables TEMP

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
'Création des tables TEMP et transfert des champs des fichiers excel********************************************************************************
 
Set wb = xlApp.Workbooks.Open(strRepTraitement & fileName, True, False)
Set ws = wb.Worksheets("Tabelle1")
ws.Activate
 
 
'*****Import into Contact T1
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "AibToolReg_TEMP_IMPORT_Header_Contact", strRepTraitement & fileName, False, "a5:d8"
       '*****Import into  Add1
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "AibToolReg_TEMP_IMPORT_Header_ShipmentAdd_1", strRepTraitement & fileName, False, "a11:a11"
'*****Import into  Add2
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "AibToolReg_TEMP_IMPORT_Header_ShipmentAdd_2", strRepTraitement & fileName, False, "a12:a12"
'*****Import into  Add3
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "AibToolReg_TEMP_IMPORT_Header_ShipmentAdd_3", strRepTraitement & fileName, False, "a13:a13"
'*****Import into  Add4
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "AibToolReg_TEMP_IMPORT_Header_ShipmentAdd_4", strRepTraitement & fileName, False, "a14:a14"
'*****Import into  Add5
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "AibToolReg_TEMP_IMPORT_Header_ShipmentAdd_5", strRepTraitement & fileName, False, "a15:a15"
'*****Import into  Add6
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "AibToolReg_TEMP_IMPORT_Header_ShipmentAdd_6", strRepTraitement & fileName, False, "a16:a16"
'*****Import into  Comments
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "AibToolReg_TEMP_IMPORT_Header_Comments", strRepTraitement & fileName, False, "d11:f14"
'*****Import into  Body
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "AibToolReg_TEMP_IMPORT_Body", strRepTraitement & fileName, False, "a18:g33"
'*****Import into  Footer
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "AibToolReg_TEMP_IMPORT_Footer", strRepTraitement & fileName, False, "a36:a36"
 
 
'Saisie d'une clé ou date du document dans deux champs de 2 tables... c'est lourdingue !
DoCmd.RunSQL "UPDATE AibToolReg_TEMP_IMPORT_Body SET [F3]= [Fill the key] "
DoCmd.RunSQL "UPDATE AibToolReg_TEMP_IMPORT_Header_Comments SET [F2]= [Fill the key]"
'Fermeture Excel********************************************************************************
wb.Close False
xlApp.Visible = False
xlApp.Quit
Set xlApp = Nothing
'Requetes ajout et supp************************************************************************************
 
DoCmd.SetWarnings False
 
DoCmd.OpenQuery "R003_Ajout_AllAibToolRequestVers_T0003_CumulHeaderFooter"
DoCmd.OpenQuery "R004_Ajout_AllAibToolRequesterVers_T0004_BodyCumul"
 
DoCmd.RunSQL "DROP TABLE AibToolReg_TEMP_IMPORT_Header_Contact"
DoCmd.RunSQL "DROP TABLE AibToolReg_TEMP_IMPORT_Header_ShipmentAdd_1"
DoCmd.RunSQL "DROP TABLE AibToolReg_TEMP_IMPORT_Header_ShipmentAdd_2"
DoCmd.RunSQL "DROP TABLE AibToolReg_TEMP_IMPORT_Header_ShipmentAdd_3"
DoCmd.RunSQL "DROP TABLE AibToolReg_TEMP_IMPORT_Header_ShipmentAdd_4"
DoCmd.RunSQL "DROP TABLE AibToolReg_TEMP_IMPORT_Header_ShipmentAdd_5"
DoCmd.RunSQL "DROP TABLE AibToolReg_TEMP_IMPORT_Header_ShipmentAdd_6"
DoCmd.RunSQL "DROP TABLE AibToolReg_TEMP_IMPORT_Header_Comments"
DoCmd.RunSQL "DROP TABLE AibToolReg_TEMP_IMPORT_Body"
DoCmd.RunSQL "DROP TABLE AibToolReg_TEMP_IMPORT_Footer"
 
DoCmd.SetWarnings True
 
'Déplacement du fichier traité et boucle pour traitement du suivant******************************************************************************
 
sEmplacementFinal = strRepArchivage & rep
FileCopy strRepTraitement & rep, sEmplacementFinal
 
Kill (strRepTraitement & rep)
'passe à l'élément suivant
rep = Dir
'End If
 
Loop

Si quelqu'un a une idée... je suis preneur.

Merci
Totor

[hyperion13]

Salut,
Code 2 quel intérêt d'activer Excel puisque vous utilisez la méthode DoCmd.TransferSpreadsheet acImport ?
Donc L3 à L5 à supprimer et tous ce qui s'y rattache L34 à L37.

Une idée pour parcourir vos classeurs situé dans un dossier

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
Private Sub btnFolder_Click()
On Error GoTo ErrorHandler
'Référence VBA : Microsoft Office xx.x Object Library
'Référence VBA : Microsoft Scripting Runtime
 
Dim dbs As DAO.Database
Dim fdg As Office.FileDialog
Dim fso As Object
Dim monDossier As Folder
Dim monFichier As File
Dim strFolderName As String
 
Set dbs = CurrentDb
Set fdg = Application.FileDialog(msoFileDialogFolderPicker)
Set fso = CreateObject("Scripting.FileSystemObject")
 
With fdg
    .AllowMultiSelect = False
    .Title = "Selectionnez un dossier"
    .InitialFileName = CurrentProject.Path & "\"
    If .Show = True Then
        strFolderName = fdg.SelectedItems(1) & "\"
        Set monDossier = fso.GetFolder(strFolderName)
        For Each monFichier In monDossier.Files
            Debug.Print "Emplacement : " & monDossier, "Nom fichier : " & monFichier.Name
            DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "tbl_Contact", monDossier & "\" & monFichier.Name, False, "A5:D8"
            CurrentDb.Execute "UPDATE tbl_Contact SET F5 = '" & monFichier.Name & "'", dbFailOnError
 
            DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "tbl_add1", monDossier & "\" & monFichier.Name, False, "A11:A11"
            CurrentDb.Execute "UPDATE tbl_add1 SET F2 = '" & monFichier.Name & "'", dbFailOnError
 
            DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "tbl_add2", monDossier & "\" & monFichier.Name, False, "A12:A12"
            CurrentDb.Execute "UPDATE tbl_add2 SET F2 = '" & monFichier.Name & "'", dbFailOnError
 
            DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "tbl_add3", monDossier & "\" & monFichier.Name, False, "A13:A13"
            CurrentDb.Execute "UPDATE tbl_add3 SET F2 = '" & monFichier.Name & "'", dbFailOnError
 
            DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "tbl_add4", monDossier & "\" & monFichier.Name, False, "A14:A14"
            CurrentDb.Execute "UPDATE tbl_add4 SET F2 = '" & monFichier.Name & "'", dbFailOnError
        Next
    End If
End With
 
ExitHandler:
    Exit Sub
ErrorHandler:
    MsgBox "Une erreur a été rencontrée !" & vbCrLf & "Error " & Err.Number & ": " & Err.Description
    Resume ExitHandler
End Sub