VBA Access Import Excel dans Access

VBA Access Import Excel dans Access - VB/VBA/VBS - Programmation

Marsh Posté le 19-05-2006 à 17:09:36    

Bonjour,
J'importe dans une base access des fichiers excel situés sur un répertoire.
Le programme me fait bien l'import des données dans ma base access, simplement lors du traitement de
plusieurs fichiers le programme bug en ouvrant la fenêtre suivante:
Fichier désormais disponible
"toto.xls" est à présent disponible pour modification
Ouvrez le fichier en lecture-écriture pour le modifier
Je suis alors obligé de tuer les processus excel pour retrouver un état normal
quelqu'un aurait-il une idée ???
D'avance merci
ci joint mon code:

 

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
 
    Repertoire = "C:\documents and Settings\Import\"
 
    Fichier = Dir(Repertoire & "*.xls" )
 
    Do While Fichier <> ""
 
    strPathToFiles = Repertoire & Fichier
 
    Set xlAppl = CreateObject("Excel.Application" )
 
    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
 
    xlAppl.Quit
    Set wb = Nothing
    Set xlAppl = Nothing
    Fichier = Dir
    Loop
 
En sub

Reply

Marsh Posté le 19-05-2006 à 17:09:36   

Reply

Marsh Posté le 22-05-2006 à 15:19:51    

Bonjour à tous,
 
après voir tout testé, mon fichier excel, debugger pas à pas, j'en suis venu à la conclusion suivante, et j'en suis presque sûr:
 
Le pb vient de ma boucle. En fait il reste toujours sur le même fichier et c'est ça qui fait planté le programme.
 
Quelqu'un sur le forum, n'aurait-il pas essayer de lire plusieurs fichiers sur un répertoire, et quel méthode (quel test de boucle) a-t-il adopté pour faire cela ?
 
D'avance merci à tous

Reply

Marsh Posté le 22-05-2006 à 17:43:28    

A adapter
 
Sub ListeFichiersTableau()  
Dim NomFichier As String, NomFichierSansExtension As String  
Dim Dossier As String, NbFichiers As Integer, Pos As Integer  
Dim Tableau() As String, i As Integer  
 
    ' Dossier de test  
    Dossier = "C:\Transfert\*.*"  
    NomFichier = Dir(Dossier)  
    Cells.Clear  
    Erase Tableau  
    NbFichiers = 0  
    Do While Len(NomFichier) > 0  
        NbFichiers = NbFichiers + 1  
        ReDim Preserve Tableau(1 To NbFichiers)  
        Pos = InStr(1, NomFichier, ".", 1)  
        NomFichierSansExtension = Left(NomFichier, Pos - 1)  
         
        Tableau(NbFichiers) = NomFichierSansExtension  
        NomFichier = Dir()  
    Loop  
     
    If NbFichiers > 0 Then  
        For i = 1 To UBound(Tableau)  
            Cells(i + 1, 1) = Tableau(i)  
        Next  
    End If  
End Sub

Reply

Marsh Posté le 22-05-2006 à 19:48:44    

Merci pour ton aide kiki29, malheureusement je n'arrive pas à faire fonctionner cela avec mon code, je pense que je vais devoir faire autrement, désolé...
 
merci de ton aide, @+

Reply

Sujets relatifs:

Leave a Replay

Make sure you enter the(*)required information where indicate.HTML code is not allowed