transfert de pages

[rocket4]

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

Code: Tout sélectionner

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

[Theze]

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) :

Code: Tout sélectionner


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é.

[rocket4]

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

à la ligne

Code: Tout sélectionner

Next xcell

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

en comprendre la raison ...

[Mytå]

Salut le forum

Selon la logique, il faut inverser les deux Next

Code: Tout sélectionner


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

       Next ws
  Next xcell
 

Mytå

[rocket4]

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