Transfert de pages

bonjour

j'ai ecris le petit code suivant qui consiste à transferet les feuilles d'un classeur B vers un classeur C à la condition que les noms des feuilles de B se retrouvent sur la plage B21:B100 d'un classeur A en feuille 1

j'y ai inclus mes etapes en explication

au depart le classeur A est ouvert

sub transfert()
dim C as workbook
dim xcell as string
dim ws as string
Dim xlApp As Excel.Application

'jouvre le classeur B :

Application.Workbooks.Open "C:\B.xls"

'j'effectue une coomparaison entre les feuilles du classeur B et la plage b21:b100 feuille 1 du classeur A :

For Each xcell In workbooks("A").Sheets("Feuil1").Range("B21:B100")  
For Each ws In workbooks("B").sheets
        If xcell = ws.name then 

'je copie les feuilles trouvées  vers un classeur C que je crée :
Set C = xlApp.Workbooks.Add
C.SaveAs ("C.xls")
ws.Copy after:=C.Sheets(C.Sheets.Count)

'je retire tout les boutons se trouvant sur les feuilles à copier dans C  :

ActiveSheet.DrawingObjects.Delete

end if 
next xcell
next ws

Workbook("B.xls).Close True

end sub

cela vous semble t il suffisant ? il y a t il des choses à corriger ?

Merci pour vos réponses

Bonsoir,

Avec quelques petites corrections mais attention, je n'ai fait aucun test (voir en pas à pas (F8) pour voir la 1ère fois ce qui se passe) :

Sub transfert()

    Dim C As Workbook
    Dim ws As Worksheet
    Dim xcell As Range

    'jouvre le classeur B :
    Application.Workbooks.Open "C:\B.xls"

    'j'effectue une coomparaison entre les feuilles du classeur B et la plage b21:b100 feuille 1 du classeur A :
    For Each xcell In Workbooks("A").Sheets("Feuil1").Range("B21:B100")

        'ici "Worksheets" pour ne parcourir que les feuilles de calculs car avec "Sheets"
        'tu passe aussi sur les feuilles graphiques et là, une erreur se produira
        For Each ws In Workbooks("B").Worksheets

            If xcell = ws.Name Then

                'je copie les feuilles trouvées  vers un classeur C que je crée :
                'ici, il faut contrôler si il existe déjà sinon, il va en créer autant
                'de fois que xcell = ws.Name sera True
                On Error Resume Next

                Set C = Workbooks("C.xls")

                If Err.Number <> 0 Then

                    Set C = Workbooks.Add '<xlApp> pas nécessaire de dire au compilateur qu'il est dans Excel, il le sais déjà ;o))
                    C.SaveAs ("C.xls")

                End If

                ws.Copy after:=C.Sheets(C.Sheets.Count)

                'je retire tout les boutons se trouvant sur les feuilles à copier dans C  :
                C.Sheets(C.Sheets.Count).DrawingObjects.Delete

            End If

        Next xcell

    Next ws

    'enregistre les modifs
    Workbook("C.xls").Save

    Workbook("B.xls").Close True

End Sub

Hervé.

Merci infiniment pour avoir repris et corrigé mon code , il reste cependant un bug que j'ai egalement rencontré

à la ligne

Next xcell 

avec l'information : "référence de variable de contrôle incorrecte dans Next sans pouvoir

en comprendre la raison ...

Salut le forum

Selon la logique, il faut inverser les deux Next

   For Each xcell . . . 
       For Each ws . . . 

       Next ws
  Next xcell

Mytå

c'est ok , j'ai remédié à ce soucis , en tout cas merci pour cette rédaction

c'est tout à fait ca Myta , ce que j'ai fais ! merci