Copier la meme cellule de plusieurs classeur dans un autre [Résolu]

Signaler
Messages postés
531
Date d'inscription
mardi 5 août 2008
Statut
Membre
Dernière intervention
2 juin 2020
-
Messages postés
531
Date d'inscription
mardi 5 août 2008
Statut
Membre
Dernière intervention
2 juin 2020
-
Bonsoir à tous,

Je voudrais copier la même cellule d’une trentaine de classeurs dans une colonne d’un autre classeur.
J’ai une trentaine de classeurs, tous identiques, avec un seul onglet et tous situés dans le même répertoire. Je voudrais, avec une macro, copier la cellule «F60» de tous les classeurs dans la colonne «A» du classeur contenant la macro.

D’avance merci pour votre aide.
Mistral

3 réponses

Messages postés
6831
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
10 juillet 2020
532
Bonjour,

Tous les classeurs sont dans le même dossier y compris celui qui contient la macro:

Sub boucle()
Dim fso As Object, dossier As Object, fichier As Object
Dim W1 As Workbook, wb As Workbook
Dim Derligne As Integer
Set W1 = Workbooks(ThisWorkbook.Name) 'classeur reception
Derligne = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1 '1ère ligne vide classeur reception
Set fso = CreateObject("Scripting.FileSystemObject")
Set dossier = fso.GetFolder(ThisWorkbook.Path) 'chemin dossier classeur
On Error Resume Next
Application.ScreenUpdating = False
For Each fichier In dossier.Files
    If fichier = ThisWorkbook.Path & "\" & ThisWorkbook.Name Then 'chemin classeur reception
    Else
    Set wb = Workbooks.Open(fichier)
         W1.ActiveSheet.Range("A" & Derligne).Value = wb.ActiveSheet.Range("F60").Value
        wb.Close
        Derligne = Derligne + 1
        End If
Next fichier
Application.ScreenUpdating = True
End Sub


voilà

Messages postés
16173
Date d'inscription
lundi 12 septembre 2005
Statut
Contributeur
Dernière intervention
14 juillet 2020
2 992
Bonjour,

Sans ouvrir les 30 classeurs: confort des yeux, rapidité

Dossier des sources différents du dossier de la macro XL4 dite de "Walkenbach"
le dossier "source" comporte tous les fichiers "source"et seulement eux

Sub transferer()
Dim lig As Long
Dim recap As String, chemin As String, onglet As String
Dim fich As String

recap = ThisWorkbook.Name
onglet = "feuil1" ' A ADAPTER
chemin = "C:/......." 'CHEMIN COMPLET DU REPERTOIRE SOURCE ?
Application.ScreenUpdating = False
Range("A2:A1000").ClearContents
lig = 2

ChDir chemin
fich = Dir("*.xls*")
While fich <> ""
If fich <> recap Then
Cells(lig, 1) = ExecuteExcel4Macro("'" & chemin & "\[" & fich & "]" & onglet & "'!R60C6") 'R60C6<==> F60
lig = lig + 1
End If
fich = Dir
Wend

MsgBox "récapitulatif terminé avec succès"
End Sub


Edit 12:00H

Petite démo (1seul dossier sources et cible)
https://mon-partage.fr/f/wPox5ag3/

Messages postés
531
Date d'inscription
mardi 5 août 2008
Statut
Membre
Dernière intervention
2 juin 2020
3
Bonjour à vous deux, Le Pivert & Michel_M

Un grand merci à vous deux pour vos réponses.
J'ai testé les deux options et le deux fonctionne.
Mais je vais garder celle de Michelle qui est beaucoup plus rapide.
C'est d'autant plus vrai que je l'ai adaptée pour créer un tableau de quatre colonnes issu des trente fichiers.

Mille mercis à vous deux.
Mistral