Copier coller une cellule de tous les onglets vers un nouveau classeur

Bonjour à tous,

Je n'ai pas trouvé la solution à mon problème.

Je souhaite copier/coller une cellule identique d'une multitude d'onglets vers un nouveau classeur.

Je souhaite que la cellule de l'onglet 1 se colle en valeur sur B2, puis la cellule de l'onglet 2 se colle en valeur sur B3 (ligne en dessous du premier copier/coller de l'onglet 1) etc etc...

Mais ça ne marche pas. Voici mon code :

[Sub Process()

Application.ScreenUpdating = False

Set CD = ThisWorkbook

Dim fichier As String

fichier = "J:\03-Directions metier & support\03-DAF\3-TRESORERIE\Banques\18- Soldes bancaires quotidien\Trésorerie Groupe Babilou " & Month(Date) - 1 & "-" & Year(Date) & ".xlsx"

If Dir(fichier) <> "" Then

Workbooks.Open fichier

Else

MsgBox ("fichier " & fichier & " inexistant")

Exit Sub

End If

Set CS = ActiveWorkbook

For Each OS In CS.Worksheets

Set OD = CD.Worksheets("Feuil1")

OS.Range("E52").Copy

OS.Range(OS.Range("E52"), OS.Range("E52").End(xlDown)).Copy OD.Cells(Application.Rows.Count, "B").End(xlUp).Offset(1, 0)

Next OS

CS.Close False

Application.ScreenUpdating = True

End Sub

Merci pour vos réponses.

Vincent

Bonjour,

Tu as ajouté beaucoup de variables (non déclarées) avec des noms que je trouve pas très parlant. J'ai donc prit la liberté de réécrire ton code à ma sauce :

Sub Process()

Dim fichier As String, Feuille As Integer, Lig As Long

Application.ScreenUpdating = False

fichier = "J:\03-Directions metier & support\03-DAF\3-TRESORERIE\Banques\18- Soldes bancaires quotidien\Trésorerie Groupe Babilou " & Month(Date) - 1 & "-" & Year(Date) & ".xlsx"
If Dir(fichier) <> "" Then
    Workbooks.Open fichier
Else
    MsgBox ("fichier " & fichier & " inexistant")
    Exit Sub
End If
With ActiveWorkbook
    Lig = ThisWorkbook.Worksheet(1).Range("B" & Rows.Count).End(xlUp).Row
    For Feuille = 1 To .Worksheets.Count
        ThisWorkbook.Worksheet(1).Range("B" & Lig + Feuille) = .Worksheet(Feuille).Range("E52")
    Next Feuille
    .Close False
End With

End Sub

Bonjour,

Merci pour ta réponse. Mais cela ne fonctionne pas, il bloque sur ces lignes

Lig = ThisWorkbook.Worksheet(1).Range("B" & Rows.Count).End(xlUp).Row

For Feuille = 1 To .Worksheets.Count

ThisWorkbook.Worksheet(1).Range("B" & Lig + Feuille) = .Worksheet(Feuille).Range("E52")

Next Feuille

On doit copier la cellule E52 sur la feuille où l'on lance la macro, sur la cellule B à la suite du copier/coller précédent.

Par exemple, sur le classeur "Trésorerie Groupe Babilou 6-2019", la macro doit venir chercher dans l'onglet 1, la cellule E52 puis la coller en B2 du classeur "Intérêts découverts", puis idem avec l'onglet 2 du premier fichier et elle vient le coller en B3....

Merci

Vincent

C'est ma faute, j'ai oublié les "s" aux objets "Worksheets" :

Sub Process()

Dim fichier As String, Feuille As Integer, Lig As Long

Application.ScreenUpdating = False

fichier = "J:\03-Directions metier & support\03-DAF\3-TRESORERIE\Banques\18- Soldes bancaires quotidien\Trésorerie Groupe Babilou " & Month(Date) - 1 & "-" & Year(Date) & ".xlsx"
If Dir(fichier) <> "" Then
    Workbooks.Open fichier
Else
    MsgBox ("fichier " & fichier & " inexistant")
    Exit Sub
End If
With ActiveWorkbook
    Lig = ThisWorkbook.Worksheets(1).Range("B" & Rows.Count).End(xlUp).Row
    For Feuille = 1 To .Worksheets.Count
        ThisWorkbook.Worksheets(1).Range("B" & Lig + Feuille) = .Worksheets(Feuille).Range("E52")
    Next Feuille
    .Close False
End With

End Sub