Forum |  HardWare.fr | News | Articles | PC | Prix | S'identifier | S'inscrire | Aide | Shop Recherche
677 connectés 

  FORUM HardWare.fr
  Programmation
  VB/VBA/VBS

  Macro vba récupérant les données de fichiers de sous dossiers

 



 Mot :   Pseudo :  
 
Bas de page
Auteur Sujet :

Macro vba récupérant les données de fichiers de sous dossiers

n°2244893
arnaud9218
Posté le 04-12-2014 à 13:19:21  profilanswer
 

Bonjour à tous,
 
Je viens à vous pour un petit conseil par rapport à une macro vba que j'ai construit dans le but de :
Récupérer des données de fichiers (dans des cellules bien précises), chacun d'eux étant contenu dans un sous dossiers, et les 53 sous dossiers sont contenus dans un même dossier. La macro se réalise grâce au chemin du dossier contenant.  
Problème la macro s'exécute mais au bout de 15 sous dossiers ouverts (environ) j'ai un message d'erreu comme quoi la fonction Workbooks.open ne peut pas être exécutée. Auriez vous une idée du problème..?
Merci d'avance, voici mon code :
 
 
Option Explicit
 
Sub ScanRepertoiresFichiersEtRepercutionBilan()
 
Dim Dossier As Object, Fichier As Object
Dim Chemin1 As String
Dim Chemin As String, CeFichier As String, ExtFichier As String
Dim TabDossiers As Variant
Dim n As Long, D As Long
Dim PlFichier As Range
Dim titre As String
Dim wbk1 As Workbook 'fichier suivi ouvert et qui contient la macro
Dim wbk2 As Workbook 'fichiers à ouvrir
 
Set wbk1 = ThisWorkbook 'fichier bilan ouvert
 
    Application.DisplayAlerts = False
    Chemin = "G:\Audit\Audits 5S\PROJET\Sauvegarde Audits 5S 2014"
    If Chemin = "" Then Exit Sub
    Application.ScreenUpdating = False
    CeFichier = ThisWorkbook.Name
    n = 2
    TabDossiers = lstDossiers(Chemin, True)
    For D = 1 To UBound(TabDossiers)
        'Chemin du dossier (ou sous-dossier) à analyser
        Chemin = TabDossiers(D)
        If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"
        'Analyse du dossier (ou sous-dossier)
        Set Dossier = CreateObject("Scripting.FileSystemObject" ).GetFolder(Chemin)
      For Each Fichier In Dossier.Files
            If Fichier.Name <> CeFichier Then
                    'action sur le fichier detecté
                    If ExtFichier = "" Or UCase(Right(Fichier.Name, 1)) = ExtFichier Then
                                   Set wbk2 = Workbooks.Open(Chemin & Fichier.Name)
                                    wbk1.Sheets(1).Range("A" & n).Value = wbk2.Sheets(12).Range("G1" ).Value
                                    wbk1.Sheets(1).Range("B" & n).Value = wbk2.Sheets(12).Range("C46" ).Value
                                    wbk1.Sheets(1).Range("C" & n).Value = wbk2.Sheets(12).Range("R2" ).Value
                                    wbk1.Sheets(1).Range("D" & n).Value = wbk2.Sheets(12).Range("E33" ).Value
                                    wbk1.Sheets(1).Range("E" & n).Value = wbk2.Sheets(12).Range("E34" ).Value
                                    wbk1.Sheets(1).Range("F" & n).Value = wbk2.Sheets(12).Range("F37" ).Value
                                    wbk1.Sheets(1).Range("G" & n).Value = wbk2.Sheets(12).Range("Y3" ).Value
                                    wbk1.Sheets(1).Range("H" & n).Value = wbk2.Sheets(12).Range("AH3" ).Value
                                    wbk2.Close
                                    n = n + 1
                    End If
                    'fin de l'action sur le fichier
            End If
        Next
    Next D
    Set Dossier = Nothing
    'Rétablit l'alerte de lien éventuelle dans les options Excel
    Application.ScreenUpdating = True
     
End Sub
 
 
Private Function lstDossiers(Chemin As String, Optional Debut As Boolean) As Variant
Dim Dossier As Object, SD As Object, C As Object
Static TabTemp() As String
    If Debut Then
        ReDim TabTemp(1 To 1)
        TabTemp(1) = Chemin
    End If
    Set Dossier = CreateObject("Scripting.FileSystemObject" ).GetFolder(Chemin)
    'examen du dossier courant
    For Each C In Dossier.subfolders
        ReDim Preserve TabTemp(1 To UBound(TabTemp) + 1)
        TabTemp(UBound(TabTemp)) = C.Path
    Next
    'Traitement récursif des sous-dossiers
    For Each SD In Dossier.subfolders
      lstDossiers SD.Path
    Next SD
    lstDossiers = TabTemp()
    Set Dossier = Nothing
End Function
 

mood
Publicité
Posté le 04-12-2014 à 13:19:21  profilanswer
 

n°2244898
Marc L
Posté le 04-12-2014 à 13:50:34  profilanswer
 

 
            Bonjour.
 
            Conformément aux règles du forum :
 
            • merci d'éditer le post et de baliser le code via l'icône dédiée !
 
            • Indiquer le n° de la ligne du code déclenchant cette erreur ainsi que le n° d'erreur et son message …
 
            Vérifier si le chemin existe, ses propriétés comme celles du fichier …
            Voir aussi la fonction VBA Dir pour parcourir les fichiers.
            Utiliser l'instruction With … End With permettrait d'alléger le code …
  

n°2244918
arnaud9218
Posté le 04-12-2014 à 15:00:11  profilanswer
 

Marc L a écrit :

 
            Bonjour.
 
            Conformément aux règles du forum :
 
            • merci d'éditer le post et de baliser le code via l'icône dédiée !
 
            • Indiquer le n° de la ligne du code déclenchant cette erreur ainsi que le n° d'erreur et son message …
 
            Vérifier si le chemin existe, ses propriétés comme celles du fichier …
            Voir aussi la fonction VBA Dir pour parcourir les fichiers.
            Utiliser l'instruction With … End With permettrait d'alléger le code …
  


 
Bonjour Marc L,
 
Désolé pour les oublis, j'y ferai attention.
 
Je vais essayer avec la fonction Dir. Sinon mon chemin est bon dans la mesure où les données se remplissent dans mon fichier wbk1 pour les 15 premiers fichiers wbk2 mais après j'obtiens le message d'erreur 1004.


Aller à :
Ajouter une réponse
  FORUM HardWare.fr
  Programmation
  VB/VBA/VBS

  Macro vba récupérant les données de fichiers de sous dossiers

 

Sujets relatifs
probleme sur une macroMacro Excel supprimer une ligne
Gestion de Base de données partagées ExcelMacro VBA Powerpoint - Suppression de plusieurs slides
Boucle de macro en échec[VBA] Recherche de fichiers et opérations entre ces fichiers
Macro VBA Powerpoint pour supprimer plusieurs liens sélectionnés[Excel][VBA] Ajouter plusieurs séries à un plot nb données variables
Récupérer TOUT les fichiers contenus dans TOUT les dossiers 
Plus de sujets relatifs à : Macro vba récupérant les données de fichiers de sous dossiers


Copyright © 1997-2018 Hardware.fr SARL (Signaler un contenu illicite) / Groupe LDLC / Shop HFR