Récupérer des données de plusieurs Excel

Version imprimable

2 pièce(s) jointe(s)

Bonjour à tous,

Etant complètement novice en VBA, je suis complètement bloqué sur une macro.
J'ai réalisé un questionnaire de satisfaction destiné aux employés d'agences de voyage.

Devant le nombre énorme de retours, il est impossible de récupérer les infos de chaque questionnaire un par un.
J'ai donc créé un fichier bilan afin de compiler les résultats de tous les questionnaires se trouvant dans un dossier définis.

Le problème est que dans mon code actuel, je dois préciser le fichier à ouvrir. Je souhaiterais que la macro ouvre tous les fichiers présents dans un répertoire défini puis copie les cellules (toujours les mêmes) et les colles côte à côte dans le fichier Bilan sur la feuille "Données"

Voici mon code :

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
Sub CreationSynthese()
'Création des titres
Range("A8") = "Confort acoustique"
Range("A9") = "Confort visuel"
Range("A10") = "Confort olfactif"
Range("A11") = "Confort hygrométrique"
Range("A12") = "Confort thermique"
Range("A13") = "Gestion des déchets"
Range("A14") = "Gestion de l'eau"
Range("A15") = "Accès à l'agence"
Range("A16") = "Sociétal"
 
'Ouverture du fichier "Questionnaire 1"
Workbooks.Open "...\Questionnaire 1.xlsm" 'chemin vers le fichier
 
'Copier cellules de "Questionnaire 1" vers "Bilan agence"
Workbooks("Bilan agence.xlsm").Sheets(2).Range("B8") = Workbooks("Questionnaire 1.xlsm").Sheets("Résultats").Range("M21")
Workbooks("Bilan agence.xlsm").Sheets(2).Range("B9") = Workbooks("Questionnaire 1.xlsm").Sheets("Résultats").Range("M22")
Workbooks("Bilan agence.xlsm").Sheets(2).Range("B10") = Workbooks("Questionnaire 1.xlsm").Sheets("Résultats").Range("M23")
Workbooks("Bilan agence.xlsm").Sheets(2).Range("B11") = Workbooks("Questionnaire 1.xlsm").Sheets("Résultats").Range("M24")
Workbooks("Bilan agence.xlsm").Sheets(2).Range("B12") = Workbooks("Questionnaire 1.xlsm").Sheets("Résultats").Range("M25")
Workbooks("Bilan agence.xlsm").Sheets(2).Range("B13") = Workbooks("Questionnaire 1.xlsm").Sheets("Résultats").Range("M26")
Workbooks("Bilan agence.xlsm").Sheets(2).Range("B14") = Workbooks("Questionnaire 1.xlsm").Sheets("Résultats").Range("M27")
Workbooks("Bilan agence.xlsm").Sheets(2).Range("B15") = Workbooks("Questionnaire 1.xlsm").Sheets("Résultats").Range("M28")
Workbooks("Bilan agence.xlsm").Sheets(2).Range("B16") = Workbooks("Questionnaire 1.xlsm").Sheets("Résultats").Range("M29")
 
'Fermeture du fichier "Questionnaire 1"
Workbooks("Questionnaire 1.xlsm").Close
 
'Ouverture du fichier "Questionnaire 1"
Workbooks.Open "\Questionnaire 2.xlsm" 'chemin vers le seconf fichier
 
'Copier cellules de "Questionnaire 2" vers "Bilan agence"
Workbooks("Bilan agence.xlsm").Sheets(2).Range("C8") = Workbooks("Questionnaire 2.xlsm").Sheets("Résultats").Range("M21")
Workbooks("Bilan agence.xlsm").Sheets(2).Range("C9") = Workbooks("Questionnaire 2.xlsm").Sheets("Résultats").Range("M22")
Workbooks("Bilan agence.xlsm").Sheets(2).Range("C10") = Workbooks("Questionnaire 2.xlsm").Sheets("Résultats").Range("M23")
Workbooks("Bilan agence.xlsm").Sheets(2).Range("C11") = Workbooks("Questionnaire 2.xlsm").Sheets("Résultats").Range("M24")
Workbooks("Bilan agence.xlsm").Sheets(2).Range("C12") = Workbooks("Questionnaire 2.xlsm").Sheets("Résultats").Range("M25")
Workbooks("Bilan agence.xlsm").Sheets(2).Range("C13") = Workbooks("Questionnaire 2.xlsm").Sheets("Résultats").Range("M26")
Workbooks("Bilan agence.xlsm").Sheets(2).Range("C14") = Workbooks("Questionnaire 2.xlsm").Sheets("Résultats").Range("M27")
Workbooks("Bilan agence.xlsm").Sheets(2).Range("C15") = Workbooks("Questionnaire 2.xlsm").Sheets("Résultats").Range("M28")
Workbooks("Bilan agence.xlsm").Sheets(2).Range("C16") = Workbooks("Questionnaire 2.xlsm").Sheets("Résultats").Range("M29")
 
'Fermeture du fichier "Questionnaire 1"
Workbooks("Questionnaire 2.xlsm").Close
 
End Sub

Je met mes fichiers en pj pour les bonnes âmes souhaitant m'apporter de l'aide. :)
Merci d'avance :)

24/01/2017, 13h13
jerome.vaussenat

Salut,

pour traiter les fichiers d'un dossier; tu peux t'inspirer de ce tuto.
http://excel.developpez.com/faq/?pag...riptingRuntime

Bonne lecture. En espérant que cela correspond à ce que tu cherches.

1 pièce(s) jointe(s)

Bonjour,

J'avais fait ceci pour un collègue:

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
Sub test()
 Dim Fso As Object, MonRepertoire As String
 Dim f1 As Object, f2 As Object, wb As Workbook
 Dim dl As Long, wbdl As Long, wbdc As Long
 
 Set Fso = CreateObject("Scripting.FileSystemObject")
 MonRepertoire = ThisWorkbook.Sheets("to do").Range("chemin")
 
 'supression si demandé des données de la feuille data
 If ThisWorkbook.Sheets("to do").Range("supr") = "Oui" Then ThisWorkbook.Sheets("data").Cells.ClearContents
 
'boucle sur les fichiers
 For Each f1 In Fso.GetFolder(MonRepertoire).Files
    If f1.Name Like "*.xlsx" Then
        Set wb = Workbooks.Open(f1)
        dl = ThisWorkbook.Sheets("data").Range("A" & Rows.Count).End(xlUp).Row
        If dl = 1 Then
            wb.Sheets(1).Cells(1, 1).CurrentRegion.Copy
            ThisWorkbook.Sheets("data").Cells(dl, 1).PasteSpecial xlValues
            Application.CutCopyMode = False
            wb.Close
        Else
            If ThisWorkbook.Sheets("to do").Range("entete") = "Non" Then
                wb.Sheets(1).Cells(1, 1).CurrentRegion.Copy
                ThisWorkbook.Sheets("data").Cells(dl + 1, 1).PasteSpecial xlValues
                Application.CutCopyMode = False
                wb.Close
            Else
                wbdl = Range("A" & Rows.Count).End(xlUp).Row
                wbdc = Cells(1, Columns.Count).End(xlToLeft).Column
                Range(Cells(2, 1), Cells(wbdl, wbdc)).Copy
                ThisWorkbook.Sheets("data").Cells(dl + 1, 1).PasteSpecial xlValues
                Application.CutCopyMode = False
                wb.Close
            End If
        End If
    End If
 Next f1
 End Sub

Pièce jointe 237914
Les plages nommées correspondent aux réponses des différentes questions posées

24/01/2017, 15h30
Marc-L

Citation:

Envoyé par Bobooot

Je souhaiterais que la macro ouvre tous les fichiers présents dans un répertoire défini

C'est simple : consulter la fonction Dir dans l'aide VBA et son exemple …
27/01/2017, 19h33
Bobooot

Pas si simple que ça quand on débute...
Merci pour votre aide, vos liens m'ont aidé à trouver la solution.
:D