Discussion :

[nz210079]

Bonjour, j'ai un problème incohérent avec mon programme qui demande à ouvrir des fichiers dans un dossier. J'ai fais une boucle pour savoir s'il trouvait des fichiers dans le dossier et il me dit que non... (alors que j'ai 2 fichiers dans le dossier spécifié). Sans la boucle, j'ai le message d'erreur suivant:
"Erreur d'exécution '1004':

'fichier1.xls' introuvable. Vérifier l'orthographe du nom du classeur et la validité de l'emplacement."
Il me nomme le premier fichier et dit qu'il est introuvable alors que je ne l'ai jamais nommé dans le programme...

Y aurait-il une erreur dans l'appellation des fichiers?

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
Sub Importfiles()
Set wbdest = ActiveWorkbook
Dim test As String
 
fichier = Dir("E:\test\*.xls") 'définit les fichiers à importer en l’occurence tous les fichiers excel se trouvant dans ce répertoire
 
'test = fichier
'If Dir(test, vbDirectory) = "" Then
'    MsgBox "fichier non trouvé"
'Else
 
Do While fichier <> "" 'démarre la boucle jusqu’au dernier fichier disponible dans le répertoire
    Set wbsource = Workbooks.Open(fichier) 'ouvre le fichier actuel à importer
    Set wksNewSheet = wbsource.Sheets("sheet1") 'sélectionne la feuille de données à importer
    wksNewSheet.Activate 'active cette feuille
    wksNewSheet.Select
    Range(Cells(2, 1), Cells(3, 3)).Select 'selection des données que l’on veut importer
    Selection.Copy 'copie les données sélectionnées
    wbdest.Activate 'retourne vers le fichier de départ
    i = ActiveSheet.UsedRange.Rows.Count 'compte le nombre de lignes déjà utilisées dans ce fichier
    Cells(i + 1, 1).Select 'sélection de la cellule où on veut coller les données (la première vide)
    ActiveSheet.Paste 'colle les données
    wbsource.Close 'ferme le fichier source
    fichier = Dir 'va vers le fichier suivant à importer
    Loop 'recommece la boucle avec le fichier suivant
    wbdest.Activate
'End If
End Sub

Merci d'avance.

[jfontaine]

Bonjour,


Pas vraiment académique comme méthode.
Je te conseil d'utiliser FSO pour l'accès aux fichiers d'un 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
Dim Fso As Object
Dim FsoRepertoire As Object
Dim FsoFichier As Object
Dim i As Long
 
Dim str() As String
 
Set Fso = CreateObject("Scripting.FileSystemObject")
Set FsoRepertoire = Fso.GetFolder("C:\")
 
'Boucle sur fichiers du repertoire
i = 1
For Each FsoFichier In FsoRepertoire.Files
    str = Split(FsoFichier.Name, ".")
    If str(UBound(str)) = "xls" Then
 
         'Traitement d'importation
 
 
        i = i + 1
    End If
Next

[Vadorblanc]

Bonjour

J'utilise souvent cette macro magnifique brodée par des pros du forum qui boucle sur tous les fichiers d'un répertoire, et qui nécessite seulement d'activer la reférence "Microsoft Scripting RunTime" par VBA > Outils Références cocher Microsoft Scripting RunTime.
Adapte là pour tes besoins. Fonctionne sur Excel 2003.
Cordialement

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
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
Option Explicit
Sub Module10ConcatenerRépertoire()
 
 
'Declaration des variables
Dim Classeur_Maitre As Workbook, Classeur_Slave As Workbook
Dim oShell As Object, oFolder As Object
Dim oFolderItem As Object
Dim Tab_Files As Variant
Dim aFile As Variant
Dim ValueB7 As String 'si le contenu de la cellule B7 est numerique mettre Long ou integer a la place de string
Dim Cel As Range
Application.DisplayAlerts = False
Set Classeur_Maitre = ActiveWorkbook
Set oShell = CreateObject("Shell.Application")
Set oFolder = oShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&)
If oFolder Is Nothing Then
    MsgBox "Abandon opérateur", vbCritical
    Exit Sub
Else
  Set oFolderItem = oFolder.Self
  'MsgBox oFolderItem.Path
End If
'Fin du morceau pioché
'On recupert les fichier contenu dans le repertoire en question
Tab_Files = ListFilesInFolder(oFolderItem.Path, False) 'mettre true a la place de false pour regarder les sous repertoires et rajouter une liste d'extension pour limiter les fichiers listés (,"txt;ert;doc;xls")
For Each aFile In Tab_Files
'................................................................................................................
    Set Classeur_Slave = Workbooks.Open(aFile, ReadOnly:=True)
    'Ouvre classeur Slave sheet 1 et copie la cellule
     Classeur_Slave.Sheets(1).Select
     Selection.AutoFilter Field:=4  'Enlever les filtres
            Rows("7:7").Select
            Selection.AutoFilter
    Classeur_Slave.Sheets(1).Range("C2").Copy
    'Sélectionne la sheet 2
    With Classeur_Slave.Sheets(1)
            'Colle cellule à la 8è ligne en collage spécial valeurs si cellule A8 adjacente non vide
            For Each Cel In .Range(.Cells(8, "A"), .Cells(Rows.Count, "A").End(xlUp))
            If Cel <> "" Then Cel.Offset(0, 62).PasteSpecial Paste:=xlPasteValues
        Next Cel
    End With
   Classeur_Slave.Sheets(1).Range("A8:BK1100").Copy
  'Copie E4:AT100 du classeur Slave et le colle en collage spécial valeurs dans le Classeur Maitre de la sheet 2
    With Classeur_Maitre.Sheets(2).Range("A65536").End(xlUp)
            .Offset(1, 0).Value = Classeur_Slave.Name
            .Offset(2, 0).PasteSpecial Paste:=xlValues 'colle à la 2è ligne vers le bas
 
    End With
'...................................................................................................................
    Classeur_Slave.Close False
Next
'.....................................................................................................................
'macro à mettre ici pour ce que tu souhaites faire
'
'
'
'
'
'
'
'Sheets("Base").Copy  'Edition Déplacer ou copier une feuille sur autre classeur
 
'With ThisWorkbook
'    .Saved = True  'ne pas enregistrer
'    .Close         'ferme le fichier macros
End With
End Sub
Function ListFilesInFolder(strFolderName As String, Optional bIncludeSubfolders As Boolean = False, Optional strTypeFichier As String) As Variant
  '
  ' necessite d'activer la reference Microsoft Scripting RunTime par VBA Outils Références cocher Microsoft Scripting RunTime
  '
  Static FSO As FileSystemObject
  Static bNotFirstTime As Boolean
  Static tabType As Variant, vType As Variant
  Static dicoType As Object
  Static strResult As String
  Dim bTheFirst As Boolean
  Dim oSourceFolder As Scripting.Folder
  Dim oSubFolder As Scripting.Folder
  Dim oFile As Scripting.File
  'Static wksDest As Worksheet
  'Static iRow As Long
  'initialisation
  bTheFirst = False
    If Not bNotFirstTime Then
    'On identifie le tout premiere appel de la fonction recursive
    bTheFirst = True
        Set FSO = CreateObject("Scripting.FileSystemObject")
    Set dicoType = CreateObject("Scripting.Dictionary")
    If strTypeFichier <> "" Then
        'On cré un tableau contenant toutes les extensions / * si rien de precisé
        tabType = Split(strTypeFichier, ";")
        ' a l'aide de ce tableau on renseigne notre dictionnaire
        For Each vType In tabType
            dicoType.Add vType, "Ext"
        Next
    End If
    bNotFirstTime = True
        On Error Resume Next
    Set oSourceFolder = FSO.GetFolder(strFolderName)
    On Error GoTo 0
        'On regarde si le rep existe bien
    If oSourceFolder Is Nothing Then
      MsgBox "Le répertoir '" & strFolderName & "' n'existe pas." & vbCrLf & "L'execution va prendre fin.", vbExclamation, "Répertoir inconnu"
      GoTo finApp
    End If
    End If
    Set oSourceFolder = FSO.GetFolder(strFolderName)
    'On boucle sur tous les fichier present
  For Each oFile In oSourceFolder.Files
    'On verifie que l'extension du fichier correspond a ce qui est demandé
    If dicoType.Exists(ExtractFileExt(oFile.Name)) Or (strTypeFichier = "") Then
        'On le rajoute dans la chaine result
        strResult = strResult & oFile.Path & ";"
    End If
  Next oFile
    'Si on a l'option Sous dossier on boucle sur les sous dossiers
  If bIncludeSubfolders Then
    For Each oSubFolder In oSourceFolder.SubFolders
    'On ajoute les fichiers contenu dans ce rep dans la liste precedente
      strResult = Join(ListFilesInFolder(oSubFolder.Path, True), ";") & ";"
    Next oSubFolder
  End If
   'On supprime le dernier ";" s'il il existe
  If Right(strResult, 1) = ";" Then strResult = Left(strResult, Len(strResult) - 1)
   'On renvoi le resulta sous forme de tabelau
  ListFilesInFolder = Split(strResult, ";")
finApp:
  'Si on se trouve dans le 1er appel on reinitialise les vaiables Static
  'pour ne pas conserver des valeurs static lors d'une prochaine utilisation de la fonction
  If bTheFirst Then
    Set FSO = Nothing
    Set dicoType = Nothing
    bNotFirstTime = False
    tabType = ""
    vType = ""
    strResult = ""
  End If
End Function
Function ExtractFileExt(strName As String) As String
    If InStr(strName, ".") = 0 Then
        ExtractFileExt = ""
    Else
        ExtractFileExt = Mid(strName, InStrRev(strName, ".") + 1)
    End If
End Function
'...................................................................................................................................

[nz210079]

Bonjour,

Merci à vous, je regarde ce que ça donne mais la solution de Vadorblanc me semble plus qu'acceptable