Bonjour pobrouwers, Bonjour le forum,
Voici une apporche pour ouvrir, copier et coller depuis 1 classeur vers X classeurs.
Dans le code, j'ai noté que tu souhaite en ouvrir 1500. Cela risque d'être long.
Fais un essai sur 1 dizaine avant de lancer toute la procédure.
Il faut, avec ce code, que tes fichiers soit nommés 'nom_de_classeur1.xls' à 'nom_de_classeur1500.xls'
Fais un essai et regarde le code. Peut-être que cela te donnear une bonne base de départ.
A+
Vincent
PS: J'ai rajouté une procédure qui vient de ce forum, permettant de vérifier si un classeur est déjà ouvert.
Colle tout ce code dans un module.
'********************************************
Sub Copie_Classeur(ByVal ps_Mois As String)
'
' Macro enregistrée le 29/06/2003 par Humansoft
'
'
'
Dim zs_NomVds, zs_Msg, zs_Tit As String
Dim zi_Nbr as Integer
zs_NomVds = ActiveWorkbook.Name ' Nom du classeur actif
Application.DisplayAlerts = False
For zi_Nbr = 1 to 1500 'Nombre de classeur à ouvrir
zs_PatFic = Application.ActiveWorkbook.Path 'Chemin du classeur à ouvrir
zs_Tit = ActiveWorkbook.Name ' Titre du classeur actif
If IsFileOpen(zs_PatFic + '\\Nom_du_classeur' & Cstr(zi_Nbr) & '.xls') Then
MsgBox 'Le classeur demandé est déjà ouvert!', vbOKOnly, zs_Tit
Else
Workbooks.Open zs_PatFic + '\\Nom_du_classeur' & Cstr(zi_Nbr) & '.xls'
End If
Windows('Nom_du_fichier' & Cstr(zi_Nbr) & '.xls').Activate ' Classeur que l'on vient d'ourir
Sheets('Nom_de_la_feuille').Select 'Feuille où sont les données
Range('B24').select 'Cellule à copier
Selection.Copy
Windows(zs_NomVds).Activate 'Classeur dans lequel on veut copier
Sheets('Nom_de_la_feuille').Select ' Feuille dans laquelle on copie
Range('Cellule').select 'Cellule dans laquelle on colle la copie
ActiveSheet.Paste
Application.CutCopyMode = False
Workbooks('Nom_du_classeur' & Cstr(zi_Nbr) & '.xls').close
Next zi_Nbr
Application.DisplayAlerts = true
End Sub
Function IsFileOpen(filename As String)
' La Fonction ==================================== :
' Merci a Excellabo.com pour cette fonction. Liée à la macro
' elle permet la vérification de fichier déjà ouvert
' Frédéric Sigonneau, El-Joker, Thierry Rural, (N°701)
Dim filenum As Integer, errnum As Integer
On Error Resume Next
filenum = FreeFile()
Open filename For Input Lock Read As #filenum
Close filenum
errnum = Err
On Error GoTo 0
Select Case errnum
Case 0
IsFileOpen = False
Case 70
IsFileOpen = True
Case Else
Error errnum
End Select
End Function