Macro : Récupérer des données dans plusieurs onglets et fichiers

[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 :

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 :

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

[roidurif]

Bonjour,

J'avance à petit pas, j'ai réussi à récupérer les données fichiers par fichier vers mon fichier principal, par contre je bloque pour récupérer les données onglets par onglet vers mon fichier.

Voici le code en question.

Merci de votre aide

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
 
 
Sub valeurExterne1()
Dim ligne, colonne, rep, onglet, fichier
Dim dlng As Long
Dim FL1 As Worksheet
 
T = 6
c = 1
D = 6
G = 2
 
recap = ThisWorkbook.Name
rep = ThisWorkbook.Path
onglet = "Lundi"
ChDir rep
fichier = Dir("*.xls")
 
While fichier <> ""
If fichier <> recap Then
 
For Each FL1 In Workbook
With FL1
 
dlng = FL1.Range("A" & Rows.Count).End(xlUp).Row + 1
 
Cells(dlng, 1) = ExecuteExcel4Macro _
("'" & rep & "\[" & fichier & "]" & FL1 & "'!R" & T & "C" & c & "")
 
Cells(dlng, 2) = ExecuteExcel4Macro _
("'" & rep & "\[" & fichier & "]" & FL1 & "'!R" & D & "C" & G & "")
 
 End With
  Next FL1
 
    End If
 
    fichier = Dir
 
Wend
 
End Sub