Macro copier coller même cellule de toutes les feuilles du classeur

jujunexcelpas

XLDnaute Nouveau
Bonjour à tout le monde,
je viens rechercher encore un peu d'aide.
après avoir bien avancé sur de nombreuses macros je bloque sur une où je souhaite:
- copier la cellule F2 (par exemple) de toutes les feuilles d'un autre classeur
- coller l'ensemble des données dans un classeur indépendant
je vous met la macro suivante:

HTML:
Option Explicit
Dim Mess As Integer, r As String
Dim xnomfic As String, ficd As String, xcell As String, xnomsh As Variant
Dim xshcherchee As Worksheet
Dim classeur As Workbook
Dim wb As Workbook
Dim ws As Worksheet

 Function FichierExiste(ficd) As Boolean
    FichierExiste = Dir(ficd) <> "" And ficd <> ""
End Function


Sub Muscudétail()

Application.DisplayAlerts = False

    r = Feuil1.[D1]
    If Dir("C:\Users\coach\dropbox\joueurs\" & r, vbDirectory) = "" Then _
    MkDir "C:\Users\coach\dropbox\joueurs\" & r

    Application.ScreenUpdating = False
    xnomfic = Range("D1"): ficd = xnomfic & " Musculation.xlsx"
 ' Contrôle de l'existence du fichier ou classeur
    If FichierExiste("C:\Users\coach\dropbox\joueurs\" & r & "\" & ficd) = "Vrai" Then
   
 sélection du classeur cible et copies des cellules F2 de chaque feuille    
    Application.Workbooks.Open("C:\Users\coach\joueurs\" & r & "\" & ficd).Activate
    Sheets.Select
    Range("F2").Copy 
    'ActiveWorkbook.Save
    ActiveWorkbook.Close
    
  collage des cellules copiée dans la colonne A de la feuille 1  
    Workbooks("Classeur1").Activate
    Feuil1.Activate
    Range("A:A").Select
    ActiveSheet.Paste
    Feuil1.Activate
    
    
    End If
              
End Sub
la macro marche mais que pour la première feuille donc je suis sur qu'il manque des choses! faut il un variable supplémentaire ou autre chose !!!
Cordialement
Julien
 

st007

XLDnaute Accro
Re : Macro copier coller même cellule de toutes les feuilles du classeur

Bonsoir,
Bien que pas très bon en macro, je songe genre :
Code:
    For i = 1 To Worksheets.Count        
        [A1].Offset(i, 0).Value = Worksheets(i).[F2].Value
    Next i
donc genre,
Code:
sélection du classeur cible et copies des cellules F2 de chaque feuille    
    Application.Workbooks.Open("C:\Users\coach\joueurs\" & r & "\" & ficd).Activate
    For i = 1 To Worksheets.Count
        
        Workbooks("Classeur1").sheets(Feuil1).Range("A1").Offset(i, 0).Value = Worksheets(i).[F2].Value
    Next i  
 End Sub
mais .....
 
Dernière édition:

jujunexcelpas

XLDnaute Nouveau
Re : Macro copier coller même cellule de toutes les feuilles du classeur

Bonjour st007, bonjour le forum,
Merci pour ta réponse rapide
en ayant tout écris de la façon suivante:
HTML:
Option Explicit
Dim Mess As Integer, r As String
Dim xnomfic As String, ficd As String, xcell As String, xnomsh As Variant
Dim i As String
Dim xshcherchee As Worksheet
Dim classeur As Workbook
Dim wb As Workbook
Dim ws As Worksheet

 Function FichierExiste(ficd) As Boolean
    FichierExiste = Dir(ficd) <> "" And ficd <> ""
End Function


Sub Muscudétail()

Application.DisplayAlerts = False

    r = Feuil1.[D1]
    If Dir("C:\Users\coach\dropbox\joueurs\" & r, vbDirectory) = "" Then _
    MkDir "C:\Users\coach\dropbox\joueurs\" & r

    Application.ScreenUpdating = False
    xnomfic = Range("D1"): ficd = xnomfic & " Musculation.xlsx"
 ' Contrôle de l'existence du fichier ou classeur
    If FichierExiste("C:\Users\coach\dropbox\joueurs\" & r & "\" & ficd) = "Vrai" Then
   
 'sélection du classeur cible et copies des cellules F2 de chaque feuille
   Application.Workbooks.Open("C:\Users\coach\joueurs\" & r & "\" & ficd).Activate
    For i = 1 To Worksheets.Count
        
        Workbooks("Classeur1").Sheets(Feuil1).Range("A1").Offset(i, 0).Value = Worksheets(i).[F2].Value
    Next i
    
  'collage des cellules copiée dans la colonne A de la feuille 1
    Workbooks("Classeur1").Activate
    Feuil1.Activate
    Range("A:A").Select
    ActiveSheet.Paste
    Feuil1.Activate
    
    
    End If
              
End Sub
je me retrouve avec une erreur de compatibilité, il me surligne le i en bleu et le titre de la macro en jaune. J'ai tenté de mettre une variable i en début de macro mais rien à faire !
cordialement
Julien
 

jujunexcelpas

XLDnaute Nouveau
Re : Macro copier coller même cellule de toutes les feuilles du classeur

Bonjour pierrot93, Bonjour st007, Le forum
j'ai tester avec le changement de variable mais j'ai toujours une incompatibilité de type voici le code que j'y ai mis
HTML:
Option Explicit
Dim Mess As Integer, r As String
Dim xnomfic As String, ficd As String, xcell As String, xnomsh As Variant
Dim i As Long
Dim xshcherchee As Worksheet
Dim classeur As Workbook
Dim wb As Workbook
Dim ws As Worksheet

 Function FichierExiste(ficd) As Boolean
    FichierExiste = Dir(ficd) <> "" And ficd <> ""
End Function


Sub Muscudétail()

Application.DisplayAlerts = False

    r = Feuil1.[D1]
    If Dir("C:\Users\coach\dropbox\Joueurs\" & r, vbDirectory) = "" Then _
    MkDir "C:\Users\coach\dropbox\Joueurs\" & r

    Application.ScreenUpdating = False
    xnomfic = Range("D1"): ficd = xnomfic & " Musculation.xlsx"
 ' Contrôle de l'existence du fichier ou classeur
    If FichierExiste("C:\Users\coach\dropbox\Joueurs\" & r & "\" & ficd) = "Vrai" Then
   
 'sélection du classeur cible et copies des cellules F2 de chaque feuille
   Application.Workbooks.Open("C:\Users\coach\dropbox\Joueurs\" & r & "\" & ficd).Activate
    For i = 1 To Worksheets.Count
        
       [COLOR="#EE82EE"] Workbooks("analyse musculation").Sheets(Feuil1).Range("A1").Offset(i, 0).Value = Worksheets(i).[F2].Value[/COLOR]
    Next i
    
  'collage des cellules copiée dans la colonne A de la feuille 1
    Workbooks("analyse musculation").Activate
    Feuil1.Activate
    Range("A:A").Select
    ActiveSheet.Paste
    Feuil1.Activate
    
    
    End If
              
End Sub
ça me surligne la ligne violette comme erreur j'ai vérifié le nom du doc la feuille et tout mais je bloque
Cordialement
Julien
 

Discussions similaires

Membres actuellement en ligne

Statistiques des forums

Discussions
294 371
Messages
1 938 081
Membres
188 641
dernier inscrit
pcayet