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

**greenfire15** · 09/08/2012, 16h56

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.

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
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.

**Ysae68** · 10/08/2012, 11h28

Bonjour,

Voici une solution alternative à tester (je n'ai que Excel 2007). La macro permet de sélectionner à son lancement les classeurs dont les cellules doivent être copiées.

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
Dim FileNameXls As Variant, i As Integer, wb As Workbook, x As Integer
 
    FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xl*", MultiSelect:=True)
    If Not IsArray(FileNameXls) Then Exit Sub
 
    Application.ScreenUpdating = False
 
    x = 13 'Pour commencer à copier à partir de la cellule D13
 
    For i = LBound(FileNameXls) To UBound(FileNameXls)
 
        Set wb = Workbooks.Open(FileNameXls(i))
        wb.Sheets("Cover Page CAA").Range("F12").Copy 'Cellules à copier dans les classeurs
 
        Workbooks("test_list2.xls").Sheets("Listes_Devis").Range("D" & x).PasteSpecial
        x = x + 1
        Application.CutCopyMode = False
        wb.Close SaveChanges:=False
 
    Next i
 
    Application.ScreenUpdating = True