Discussion :

[roidurif]

Bonjour,

J'ai plusieurs fichiers contenant dix feuilles chacun situé dans un répertoire.

Le but est de récupérer deux données (cellules "A6" et "B6") situé dans les onglets ('Lundi', 'Mardi', 'Mercredi', 'Jeudi',...,'Dimanche') pour chacun des fichiers et ensuite de les rassembler en colonne dans le fichier 'Données'

Voici un bout de code, mais impossible de l'ajuster à mon fichier

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
 
 
Option Explicit
 
Sub Importer2()
Dim i As Long
Dim j As Byte
Dim sDossier As String, sFichier As String, sFeuille As Worksheet
'sFeuille As String
 
    Application.ScreenUpdating = False
 
    ShDatas.Range("B1:C65536").Clear
    sDossier = ThisWorkbook.Path & "\"
    sFeuille1 = "Lundi"
    sFeuille2 = "Mardi"
    sFeuille3 = "Mercredi"
    sFeuille4 = "Jeudi"
    sFeuille5 = "Vendredi"
    sFeuille6 = "Samedi"
    sFeuille7 = "Dimanche"
 
 
 
    For i = 1 To 4
    'For j = 1 To Sheets.Count
 
 
        With ShDatas
            sFichier = .Cells(i, 1)
            .Cells(i, 2) = ExtraireValeur(sDossier, sFichier, sFeuille1, "A6")
            .Cells(i, 2) = CDate(Cells(i, 2))
            .Cells(i, 3) = ExtraireValeur(sDossier, sFichier, sFeuille1, "B6")
            .Cells(i, 3) = Cells(i, 3)
 
        End With
 
    Next i
 
    Application.ScreenUpdating = True
End Sub
 
Private Function ExtraireValeur(ByVal Dossier As String, ByVal Fichier As String, ByVal Feuille As String, ByVal Cellule As String)
Dim Argument As String
    Argument = "'" & Dossier & "[" & Fichier & "]" & Feuille & "'!" & Range(Cellule).Address(, , xlR1C1)
    ExtraireValeur = ExecuteExcel4Macro(Argument)
End Function

[rapheb]

Mon code pour une macro similaire adapté à ton besoin je pense.
Rajoute les lignes pour la cellule A8
Place tous tes classeurs dans un même répertoire, que tu indiqueras dans le code.

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
Sub Synthese()
'déclaration type de variable
Dim Repertoire As String, Fichier As String 'texte
Dim Wb As Workbook 'classeur
Dim Ws As Worksheet 'onglet
Dim i As Integer 'nombre entier
 
Application.ScreenUpdating = False 'désactivation défilement écran
Set Ws = ThisWorkbook.Worksheets(1)
Repertoire = "X:\" 'définit le répertoire de recherche
Fichier = Dir(Repertoire & "*.xls") 'spécifie la recherche pour le fichiers .xls
 
Do While Fichier <> "" 'boucle sur les fichiers du répertoire
If ThisWorkbook.Name <> Fichier Then 'sauf sur ce fichier si dans même répertoire
Set Wb = Workbooks.Open(Repertoire & Fichier) 'ouvre chaque classeur
i = i + 1
 
Ws.Cells(i + 3, 1) = Fichier 
 
Ws.Cells(i + 3, 3) = Wb.Worksheets("lundi").Range("A2")
Ws.Cells(i + 3, 4) = Wb.Worksheets("mardi").Range("A2")
Ws.Cells(i + 3, 5) = Wb.Worksheets("mercredi").Range("A2")
Ws.Cells(i + 3, 6) = Wb.Worksheets("jeudi").Range("A2")
Ws.Cells(i + 3, 7) = Wb.Worksheets("vendredi").Range("A2")
Ws.Cells(i + 3, 8) = Wb.Worksheets("samedi").Range("A2")
Ws.Cells(i + 3, 9) = Wb.Worksheets("dimanche").Range("A2")
 
Wb.Close False 'referme le classeur sans sauvegarder
Fichier = Dir
Loop
 
Application.ScreenUpdating = True 'résactivation défilement écran
End Sub

[roidurif]

Bonjour rapheb,

Ta proposition est intéressante, Mais me convient pas car elle ouvre les fichiers un à un, alors ce que je souhaite par rapport à ma macro c'est de lire les données sans ouvrir les fichier.

[Qwazerty]

Salut
Si tu veux lire tes données sans ouvrir le fichier voila un tutoriel à se sujet.
++
Qwaz

[roidurif]

Bjr,

Merci pour l'astuce, mais je ne sais pas comment m y prendre pour lire onglet par ongler, fichier par fichier avec ce type de connexion


Merci pour votre aide

[ZebreLoup]

Tout est expliqué dans le tutoriel donné par Qwazerty.
Sinon tu peux aussi créer un autre objet Excel que tu dois pouvoir masquer