[XL-2010] Ouverture de fichiers dans répertoire variable [Résolu]

[Bpillon]

Bonjour.
J'ai un ensemble de fichiers (toujours nommés de la même manière) contenus dans des répertoires différents (1 rep par société). Je compile les données dans une base (1 ligne par société, 40 lignes). Quel est le code pour ouvrir une fenêtre de dialogue demandant de spécifier le chemin contenant les fichiers à importer (donc pour 1 société donnée), puis d'utiliser ce chemin pour l'ouverture des fichiers automatiquement ?

Merci beaucoup, beaucoup...

[patricktoulon]

bonjour dans l'aide tu peux regarder du coté de filedialog

le premier exemple te donne un exemple assez precis qui pourrais t'intérésser

au plaisir

[Vadorblanc]

Bonjour

Quel est le code pour ouvrir une fenêtre de dialogue demandant de spécifier le chemin contenant les fichiers à importer (donc pour 1 société donnée), puis d'utiliser ce chemin pour l'ouverture des fichiers automatiquement ?

Un code que j'utilise pour pointer sur un répertoire au choix et qui copie ensuite une partie d'une feuille ou ce que tu veux de tous les fichiers contenus dans le répertoire, à toi d'adapter dans la partie que j'ai mis 'adapte ton code.
Cordialement

Code :

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
Option Explicit
Sub Module01ConcatenerRé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)                                         'adapte ton code
        'Ouvre classeur Slave sheet 1 et copie la cellule                                              'adapte ton code
     Classeur_Slave.Sheets("Celle que tu veux").Select                                                 'adapte ton code
 
    Classeur_Slave.Sheets("Celle que tu veux").Range("A1:AA2").Copy                                    'adapte ton code
 
  'Copie du classeur Slave et le colle en collage spécial valeurs dans le Classeur Maitre de la sheets 2 'adapte ton code
    With Classeur_Maitre.Sheets(2).Range("A65536").End(xlUp)                                             'adapte ton code
            '.Offset(1, 0).Value = Classeur_Slave.Name                                                   'adapte ton code
            .Offset(2, 0).PasteSpecial Paste:=xlValues 'colle à la 2è ligne vers le bas                  'adapte ton code
 
    End With
'...................................................................................................................
    Classeur_Slave.Close False
Next
 
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
'...................................................................................................................................

[Bpillon]

Merci pour ces précisions.
J'ai dejà tenté de passer par le code décrit dans l'help du filedialog.

le soucis est lorsque j'ultilise la variable contenant le chemin pour ouvir les fichiers, j'ai un retour de fichier inexistant

Code :

Workbooks.Open Filename:=vrtSelectedItem & "3 - AIPC.XLS", UpdateLinks:=0

[Bpillon]

J'ai trouvé...En fait je faisais un appel à la variable du chemin en dehors du code du filedialog. En intégrant l'ouverture entre for et next cela fonctionne très bien !

Code :

1
2
3
4
5
If .Show = -1 Then
             For Each vrtSelectedItem In .SelectedItems
                'fd.Execute
                MsgBox "Import dans le répertoire : " & vrtSelectedItem
                Workbooks.Open Filename:=vrtSelectedItem & "\3 - AIPC.XLS", UpdateLinks:=0