Macro pour récupérer la cellule B4 sur Plusieurs fichiers .xlsx vers un nouveau classeur

Version imprimable

Bonjour Chère communauté
je réalise actuellement un stage dans une société.
il m'as été accordé la tache de:
Élaborer une Macro qui permettrai de récupérer la cellule B4 sur Plusieurs fichiers .xlsx (2000) contenus dans un seul Dossier vers un nouveau classeur
je suis vraiment pas débutant sur de la programmation
(il me faut un bon temps d'analyse pour comprendre la logique du code)

en cherchant sur internet j'ai trouvé des bouts de code sur mon sujet
à présent j'arrive à ouvrir le classeur récepteur et un des fichier, avec un boucle, d'où on copie la cellule B4

mais j'ai une erreur sur la ligne qui copie la cellule
je vous met une capture de mon code

pourriez vous m'aider S'il vous plait
je vous remercie d'avance et peut mieux développer si je me suis pas bien fait comprendre
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 Option Explicit Sub Macro1() Dim FSO As Object Dim file_fichierNT As Object ' // Quelques variables Dim wb_maitre As Workbook Dim wb_fichierNT As Workbook Dim cells As Integer '//cells = Workbooks(Selection.Value).Sheets(Selection.Value).Range("B4").Value Set FSO = CreateObject("Scripting.FileSystemObject") '// declare une variable pour la cellule A1 Set wb_maitre = Workbooks.Open("C:\Users\usertests\Documents\macro_excel\maitre\maitre.xlsx") ' // On ouvre le classeur maître For Each file_fichierNT In FSO.GetFolder("C:\Users\usertests\Documents\macro_excel\").Files ' // On vérifie a priori que le fichier est un classeur (XLS) If UCase(file_fichierNT.Name) Like "*.XLSX" Then Set wb_fichierNT = Workbooks.Open(file_fichierNT.Path, ReadOnly:=True) file_fichierNT.Worksheets("1").Activate.range("B4").Select.Copy After:=file_fichierNT ' // On ferme le classeur quesTP, sans rien enregistrer - euh, à quoi sert le readonly alors ??? wb_fichierNT.Close SaveChanges:=False End If Next End Sub
Mercie de nouveau
cordialement Wcastillo

Bonjour WCastillo, bonjour le forum,

Au niveau de la copie le code que tu utilises est erroné tu as mélangé, il me semble, la copie d'un onglet et celle d'une cellule. Le code que je te propose utilise une autre méthode pour l'ouverture des fichiers mais surtout il copie le cellule B4 de chaque fichier dans la colonne A (tu adapteras si nécessaire) du classeur Maître. Ce code, d'ailleurs, est à placer dans ce classeur maître :

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
Sub Macro1()
Dim CM As Workbook 'déclare la variable CM (Classeur Maître)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim F As String 'déclare la variable F (Fichier)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
 
Set CM = ThisWorkbook 'définit le classeur maître CM
CA = "C:\Users\usertests\Documents\macro_excel\" 'définit le chemin d'accès CA
F = Dir(CA & "*.xlsx") 'définit le premier fichier F du chemin d'accès CA ayant une extension .xlsx
Do While F <> "" 'exécute tant qu'il existe des fichiers
    'condition : si A1 de l'onglet 1 du classeur maître CM est vide
    If CM.Sheets(1).Range("A1").Value = "" Then 'définit la cellule de destination DEST : A1
        Set DEST = CM.Sheets(1).Range("A1")
    Else 'sinon
        'définit la cellule de destination : la première cellule vide de la colonne A de l'onglet 1 du classeur CM
        Set DEST = CM.Sheets(1).Range("A" & Application.Rows.Count).End(xlUp).Offset(1, 0)
    End If 'fin de la condition
    Workbooks.Open (CA & F) 'ouvre le fichier F
    Set CS = ActiveWorkbook 'définit le classeur source CS
    CS.Sheets(1).Range("B4").Copy DEST 'copie la cellule B4 de l'onglet 1 du classeur source et la copie dans DEST
    CS.Close False 'ferme le classeur source sans enregistrer
    F = Dir 'définit le prochain fichier du chemin d'accès CA ayant une extension .xlsx
Loop 'boucle
End Sub

bonsoir
teste ca

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
Sub test()
    Dim CA$, cel As Range, Fichiers, Feuille$
    CA = "C:\Users\usertests\Documents\macro_excel"
    Feuille = "Feuil1"'adapter le nom de la feuille des fichiers
    Fichiers = Dir(CA & "\*.xlsx")
    Do While Fichiers <> ""
        With Sheets(1)
            If .Range("A1").Value = "" Then Set cel = .Range("A1") Else Set cel = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
            cel.Value = ExecuteExcel4Macro("'" & CA & "\[" & Fichiers & "]" & Feuille & "'!" & "R4C2")
        End With
        Fichiers = Dir
    Loop
End Sub