Table des matére avec donné dans cellule

Bonjour,

je voudrais écrire un code, qui copirais le contenu de une cellule spécifique sur chaque sheet de mon workbook et qui le collerais dans une nouvelle sheet apelle Table des matière. Et ensuite surprimerais la ligne 1 de chaque sheet. Voici mon code que j'ai écrit mais qui ne fonctionne pas.

' Creating table of content

Dim workshit As Worksheet
Set workshit = Sheets.Add
Sheets.Add.Name = "Table_Of_Content"

' Filling TOC
ActiveWorkbook.Sheets("Table_Of_Content").Activate
Dim WorkS As Worksheet
    For Each WorkS In ActiveWorkbook.Worksheets
    Range("B1").Copy
ActiveSheet.Paste
Application.CutCopyMode = False
    Next WorkS

Bonsoir,

Un petit fichier en pièce jointe pourrai être utile pour vous aider.

hmm le fichier fait 140 mo et contient des info un peut sensible.

Mon niveau en vba ne me permet pas de vous aider sans fichier, je passe donc la main à d'autres personnes plus compétente.

Bonne soirée.

Bonsoir,

essaye le code suivant

Sub ToC()

Dim workshit As Worksheet
Set workshit = Sheets.Add
ActiveSheet.Name = "Table_Of_Content"

aa = Sheets.Count

For i = 2 To aa
    ActiveCell = Sheets(i).Range("B1")
    ActiveCell.Offset(1, 0).Select
Next i

End Sub

SUPER merci beaucoup !

Et pour un peut poussé, si je voulais que la macro prenne en compte touts les sheet saufe une nommé "SynthesisVSD".

essaye ça :

Sub ToC()

Dim workshit As Worksheet
Set workshit = Sheets.Add
ActiveSheet.Name = "Table_Of_Content"

aa = Sheets.Count

For i = 2 To aa
    If Sheets(i).Name<>"SynthesisVSD" Then
        ActiveCell = Sheets(i).Range("B1")
        ActiveCell.Offset(1, 0).Select
    End If
Next i

End Sub

Merci beaucoup ! vraiment super !