Comptage du nombre de feuille d'un classeur

Bonjour

je bloque un peu pour réaliser une macro de comptage du nombre de feuille d'un classeur B et qui renverrai le resultat

dans une cellule choisie ( par exemple B6) de la 2 ieme feuille de mon classeur A

j'ai ecris ceci ::

Private Sub Worksheet_Activate()
range("B6")=ActiveWorkbook.Sheets.count

ce que je n'arrive pas à ecrire c'est la localisation de la cellule b6 qui doit se situer dans le classeur A , feuille 2

merci pour votre aide

Bonjour rocket4,

Essaie comme ceci (le classeur A étant ouvert) :

    Private Sub Worksheet_Activate()
    Workbooks("Classeur A").Sheets("Feuil2").Range("B6")=ActiveWorkbook.Sheets.count

Merci à toi , bonne soirée

re... au final ca ne marche pas trop , c'est peut etre du à un manque de precision de ma part

au depart j'ai le code suivant

Sub a()
Dim Ws As Worksheet
Dim WbkD As Workbook

  Application.ScreenUpdating = False
  With ThisWorkbook
    For Each Ws In .Sheets
      If Ws.Range("H7") <> "" Then
        If WbkD Is Nothing Then
          Ws.Copy
          Set WbkD = ActiveWorkbook
        Else
          Ws.Copy after:=WbkD.Sheets(WbkD.Sheets.Count)
        End If
        ActiveSheet.DrawingObjects.Delete
        ActiveSheet.Name = Ws.Range("H7")
        Ws.Range("H7").ClearContents
      End If
    Next Ws
  End With

  If Not WbkD Is Nothing Then
    With WbkD
      .SaveAs "C:\Users\ROCKET\Desktop\Nouveau dossier (8)\Extraction de feuille.xls"
      ' Ma sauvegarde : Evite d'avoir le même nom
'      .SaveAs ThisWorkbook.Path & "\Extraction de feuille le " & Format(Now, "yyyy mm dd hhmmss") & ".xls"
     .Close
    End With
  Else
    MsgBox "Pas de feuilles à copier"
  End If
End Sub

je voudrai inclure dans ce code une ligne de comptage des feuilles du classeur crée qui s'appelle "Extraction de feuille " et qui me renverrai cette valeur dans un classeur nommé A , feuil2 ,cellule C33

j'ai essayé d'adapter ta précedente réponse à ce code sans succès

merci pour toute intervention

voici ce que j'ai fait qui et qui n'a pas marché :

Workbooks("Extraction de feuille.xls").Sheets.Count = Workbooks("A.xls").Sheets("Feuil2").Range("C33")

que j'ai intercalé dans le precédent code de la facon suivante

    Sub a()
    Dim Ws As Worksheet
    Dim WbkD As Workbook

      Application.ScreenUpdating = False
      With ThisWorkbook
        For Each Ws In .Sheets
          If Ws.Range("H7") <> "" Then
            If WbkD Is Nothing Then
              Ws.Copy
              Set WbkD = ActiveWorkbook
            Else
              Ws.Copy after:=WbkD.Sheets(WbkD.Sheets.Count)
            End If
            ActiveSheet.DrawingObjects.Delete
            ActiveSheet.Name = Ws.Range("H7")
            Ws.Range("H7").ClearContents
          End If
        Next Ws
      End With

      If Not WbkD Is Nothing Then
        With WbkD
          .SaveAs "C:\Users\ROCKET\Desktop\Nouveau dossier (8)\Extraction de feuille.xls"
          ' Ma sauvegarde : Evite d'avoir le même nom
    '      .SaveAs ThisWorkbook.Path & "\Extraction de feuille le " & Format(Now, "yyyy mm dd hhmmss") & ".xls"
        .Close
        End With
      Else
        MsgBox "Pas de feuilles à copier"
      End If
Workbooks("Extraction de feuille.xls").Sheets.Count = Workbooks("A.xls").Sheets("Feuil2").Range("C33") ' ligne que j'ai ajoutée 
    End Sub

merci

Il faut inverser l'égalité :

[barrer]Workbooks("Extraction de feuille.xls").Sheets.Count = Workbooks("A.xls").Sheets("Feuil2").Range("C33")[/barrer]

Workbooks("A.xls").Sheets("Feuil2").Range("C33") = Workbooks("Extraction de feuille.xls").Sheets.Count

Merci pour cette correction , j'ai cependant une anomalie signalée sur cette ligne par le debugeur mentionnant un message d'erreur

du type erreur 9 "l'indice ne correspond pas à la selection "

sans en trouver la cause ! ... faut il peut etre que je declare le classeur A au debut du code ?

je joins la capture d'ecran avec la ligne surlignée en jaune

merci

Comme je l'ai dit :

vba-new a écrit :

Essaie comme ceci (le classeur A étant ouvert) :

Bonsoir

Bonsoir Vba-new

Essayes pour voir si cela ne va pas mieux

Sub a()
Dim Ws As Worksheet
Dim WbkD As Workbook

  Application.ScreenUpdating = False
  With ThisWorkbook
    For Each Ws In .Sheets
      If Ws.Range("H7") <> "" Then
        If WbkD Is Nothing Then
          Ws.Copy
          Set WbkD = ActiveWorkbook
        Else
          Ws.Copy after:=WbkD.Sheets(WbkD.Sheets.Count)
        End If
        ActiveSheet.DrawingObjects.Delete
        ActiveSheet.Name = Ws.Range("H7")
        Ws.Range("H7").ClearContents
      End If
    Next Ws
  End With

  If Not WbkD Is Nothing Then
    With WbkD
     ThisWorkbook.Sheets("Feuil2").Range("C33") = .Sheets.Count
      .SaveAs "C:\Users\ROCKET\Desktop\Nouveau dossier (8)\Extraction de feuille.xls"
      ' Ma sauvegarde : Evite d'avoir le même nom
'      .SaveAs ThisWorkbook.Path & "\Extraction de feuille le " & Format(Now, "yyyy mm dd hhmmss") & ".xls"
   .Close
    End With
  Else
    MsgBox "Pas de feuilles à copier"
  End If
End Sub

Merci Banzai pour cette réponse , mais le comptage des feuilles du classeur "extraction de feuille" doit etre reporté dans un autre classeur nommé A sur la feuille 2 et en cellule C33 et ce dernier se trouve dans le meme dossier que le classeur extraction , à la lecture de ton code , je ne vois pas ou est reporté ce comptage

Bonsoir

J'ai lu en travers

J'ai cru qu'il fallait marqué dans le classeur de la macro

Comme à dit Vba-new il te faut

Ouvrir le classeur

Y écrire

et le fermer

Mais il te faut savoir le nombre de feuilles

Voici un nouveau code (non testé)

Sub a()
Dim Ws As Worksheet
Dim WbkD As Workbook
Dim NbFeuilles as Integer

  Application.ScreenUpdating = False
  With ThisWorkbook
    For Each Ws In .Sheets
      If Ws.Range("H7") <> "" Then
        If WbkD Is Nothing Then
          Ws.Copy
          Set WbkD = ActiveWorkbook
        Else
          Ws.Copy after:=WbkD.Sheets(WbkD.Sheets.Count)
        End If
        ActiveSheet.DrawingObjects.Delete
        ActiveSheet.Name = Ws.Range("H7")
        Ws.Range("H7").ClearContents
      End If
    Next Ws
  End With

  If Not WbkD Is Nothing Then
    With WbkD
    NbFeuilles = .Sheets.Count
      .SaveAs "C:\Users\ROCKET\Desktop\Nouveau dossier (8)\Extraction de feuille.xls"
      ' Ma sauvegarde : Evite d'avoir le même nom
'      .SaveAs ThisWorkbook.Path & "\Extraction de feuille le " & Format(Now, "yyyy mm dd hhmmss") & ".xls"
   .Close
    End With
  Else
    MsgBox "Pas de feuilles à copier"
  End If

 With Workbooks.Open("A.xls")
    .Sheets("Feuil2").Range("C33") = NbFeuilles   ' ligne que j'ai ajoutée
    .Save
    .Close
  End With
End Sub

Si pas ça

merci pour ta solution , j'ai un signalement d'erreur à la ligne de code suivante ::

With Workbooks.Open("A.xls")

je joins mon fichier le classeur C1 et le classeur A se trouvent dans le meme dossier

merci

Bonsoir

Il faut rajouter le chemin

Comme ils sont dans le même répertoire

     With Workbooks.Open(ThisWorkbook.Path & "\A.xls")
        .Sheets("Feuil2").Range("C33") = NbFeuilles   ' ligne que j'ai ajoutée
        .Save
        .Close
      End With

Merci , ca marche !!!!!!! en tout cas , je salut vos compétences , il y a des pro sur le site !!!!!!