Récupérer la valeur d'une cellule dans plusieurs classeurs

Bonjour à tous,

Merci d'avance de m'accorder un peu de votre temps, pour m'aider à résoudre mon problème.

Je vous solicite car je voudrais récupérer la valeur d'une cellule dans plusieurs classeurs identiques sauf le nom qui change.

Je voudrais donc copier ces valeurs situées dans les cellules "F12" des feuilles "Cover Page CAA" de chaque classeurq afin de coller toutes ces valeurs dans un fichier "test_list2" dans la feuille "Listes_Devis" à partir de la cellule "D13".

Voilà le début du code mais sa marche pas :s, où est mon erreur.

Sub test()

Dim objFSO, objDossier

Dim mWbk As Excel.Workbook

Set objFSO = CreateObject("Scripting.FileSystemObject")

Set objDossier = objFSO.GetFolder("D:\totot\")

If (objDossier.Files.Count > 0) Then

For Each objFichier In objDossier.Files

If (InStr(1, objFichier.Name, ".xls", 1) > 0) Then

Set mWbk = Excel.Workbooks.Open(objDossier.Path & "\" & objFichier.Name)

mWbk.Worksheets("Cover page CAA").Range("F12").Value

Workbook("test_list2").Worksheets("Liste_Devis").Range("D" & 13).End(xlUp)(2).Row.Paste

mWbk.Close

Set mWbk = Nothing

End If

Next

End If

End Sub

Merci d'avance de votre aide.

Bonsoir

Un essai :

1 - Enregistre le fichier "test list2" dans le répertoire "totor"

2 - Place ce code dans un module de "test list2"

Sub Transferer()
Dim dossier As Object, Fichier As Object, Chemin As String, Lg As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = True

DerLg = Range("D65536").End(xlUp).Row + 1
Range("D13:D" & DerLg).Delete

Chemin = ThisWorkbook.Path
FName = Dir(Chemin & "\" & "*.xls")
Set dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
Lg = 13

For Each Fichier In dossier.Files    
NomFichier = Fichier.Name
If Not Fichier.Name = "test_list2.xls" Then
Workbooks.Open Filename:=Chemin & "/" & NomFichier

On Error Resume Next

With Workbooks(NomFichier)
.Sheets("Cover Page CAA").Range("F12").Copy ThisWorkbook.Sheets("Listes_Devis").Range("D" & Lg)
.Close

Lg = Lg + 1

End With
End If

Next

End Sub

Amicalement

Nad

Bonsoir,

Merci beaucoup de ton aide, je teste tous çà demain.

Je te tiens au courant du réultat.

Bonne soirée à toi

Bonjour,

Merci beaucoup Nad cela fonctionne très bien, un grand merci.

Bonne journée.

Re-bonjour,

J'ai une question, c'est peut-e^tre abusé de ta bonté, je voulais savoir comment tu fais pour inclure les sous-dossiers ?

Merci d'avance

Cordialement,