Déplacer toutes les feuilles après la 2ème dans un nouveau classeur

philippe_chalon01 · 29 Juillet 2016

Bonjour tout le monde,
J'aimerais pouvoir, avec une macro et un bouton, déplacer plusieurs feuilles (toutes les feuilles située après la 2ème feuille du classeur nommée "Rapport") dans un nouveau classeur portant le nom de la cellule "P5" de la feuille "Saisie"
J'ai utilisé le code suivant mais il y a un problème au niveau : Sheets(Sheets(i)).Move Before:=Workbooks(NomFichier & ".xls").Sheets(1)

Sub Deplacer()

Dim NbFeuilles, i As Integer
Dim NomFichier As String

NbFeuilles = Sheets.Count
i = 0

NomFichier = Sheets("Saisie").Range("P5").Value
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=NomFichier

Workbooks("Rapport 2 empreintes - copie").Activate

For i = NbFeuilles To 2 Step -1
Sheets(Sheets(i)).Move Before:=Workbooks(NomFichier & ".xls").Sheets(1)
Workbooks("Rapport 2 empreintes - copie.xls").Activate
Next i

Workbooks("Rapport 2 empreintes - copie.xls").Activate

End Sub

Merci à ceux qui prendront le temps de m'aider

Edit : Ci-joint à fichier si ça peut aider certains à comprendre

Alza · 29 Juillet 2016

Bonjour,
Sheets(i) est un objet il ne te renvoie pas le nom de la feuille, utilise Sheets(i).name.

philippe_chalon01 · 29 Juillet 2016

Bonjour,
Oui pardon il y était initialement mais je l'avais enlevé pour voir si ça allait marcher sans. Et même avec il ne marche pas.

Efgé · 29 Juillet 2016

Bonjour

Juste une question:
Workbooks("Rapport 2 empreintes - copie") est le vrai nom de ton classeur de base ?
On pourrait utiliser dans ton exemple "Fichier essai" ?

Cordialement

philippe_chalon01 · 29 Juillet 2016

Bonjour,
Oui c'était le nom original mais c'est vrai que du coup j'ai modifié le nom du fichier sans modifier les codes dans les macros, désolé.

Yurperqod · 29 Juillet 2016

Bonjour le forum

Une possibilité (sans gestion d'erreur - cellule P5 vide ou nom fichier invalide)

Code:

Sub test()
Dim Chemin As String, NomFichier As String, NouvClass As Workbook
Chemin = ThisWorkbook.Path & "\"
NomFichier = Sheets("Saisie").Range("P5").Text
Sheets(Array("123-1", "123-2", "123-3")).Copy
Set NouvClass = ActiveWorkbook
NouvClass.SaveAs Chemin & NomFichier & ".xlsx", 51
NouvClass.Close True
End Sub

Efgé · 29 Juillet 2016

Re à tous
Comme Yurperqod en pas pareil

Yurperqod à dit:
(sans gestion d'erreur - cellule P5 vide ou nom fichier invalide)

Code:

Sub Test()
Dim Tableau As Variant, nom$, i&
With ThisWorkbook
  'remplacer le ThisWorkbook.Path par le chemin du dossier nécessaire...
  nom = ThisWorkbook.Path & "\" & .Sheets("Saisie").Range("P5").Value & ".xls"
  For i = 2 To ThisWorkbook.Worksheets.Count '2 si l'on prend la feuille 2 sinon a adapter
  If Not IsArray(Tableau) Then
  Tableau = Array(.Worksheets(i).Name)
  Else
  ReDim Preserve Tableau(UBound(Tableau) + 1)
  Tableau(UBound(Tableau)) = .Worksheets(i).Name
  End If
  Next i
End With
If IsArray(Tableau) Then
  Worksheets(Tableau).Move
  ActiveWorkbook.SaveAs Filename:=nom
End If
End Sub

Cordialement

philippe_chalon01 · 29 Juillet 2016

Bonjour Yuperqod,
Merci de ton aide,
Cependant le problème est que le nom des feuilles vont être aléatoires, ce ne sera jamais les même. Il faut donc une macro qui puisse aller chercher les feuilles situées après celle "rapport" , ou tout simplement les feuilles situées après la 2ème

philippe_chalon01 · 29 Juillet 2016

Merci beaucoup Efgé, ça marche parfaitement !
Bonne fin de journée à tous,
Philippe.

Yurperqod · 29 Juillet 2016

Suite

Pour tenir compte du nombre de feuille variable, la même macro que tout à l'heure mais modifiée en conséquence.

Code:

Sub testB()
Dim Chemin As String, NomFichier As String, NouvClass As Workbook
Workbooks.Add (1): Set NouvClass = ActiveWorkbook: ThisWorkbook.Activate
Chemin = ThisWorkbook.Path & "\"
NomFichier = ThisWorkbook.Sheets("Saisie").Range("P5").Text
Sheets.Select: Sheets.Copy After:=NouvClass.Sheets(1)
Application.DisplayAlerts = False
Sheets(Array("Feuil1", "Saisie", "Rapport")).Delete
NouvClass.SaveAs Chemin & NomFichier & ".xlsx", 51: NouvClass.Close True
End Sub

Efgé · 29 Juillet 2016

Re bonjour à tous

Yurperqod à dit:
Sheets(Array("Feuil1", "Saisie", "Rapport")).Delete

Le problème est qu'il faut deviner/récupérer le nom des feuilles et non les écrire en "dur" dans le code; d'où ma proposition en s'appuyant sur leurs index.

Mais sinon, l'idée d'enregistrer tout le classeur et supprimer les feuilles est très bonne...

Cordialement

Yurperqod · 29 Juillet 2016

Bonjour Efgé

Efgé à dit:
Re bonjour à tous
Le problème est qu'il faut deviner/récupérer le nom des feuilles et non les écrire en "dur" dans le code; d'où ma proposition en s'appuyant sur leurs index.
Mais sinon, l'idée d'enregistrer tout le classeur et supprimer les feuilles est très bonne...
Cordialement

Normalement les noms des feuilles à supprimer est connu: Feuil1, Saisie, Rapport.
Et le Sheets.Select sélectionne toutes les feuilles.
Au final, le résultat est le même (mais ton code est plus sécure )
Philippe n'a plus que l'embarras du choix.
(Il reste à ajouter la gestion du contenu de la cellule P5 pour avoir un nom de fichier valide)

Efgé · 29 Juillet 2016

Yurperqod à dit:
Normalement les noms des feuilles à supprimer est connu: Feuil1, Saisie, Rapport.

Oui, tant qu'on est dans un Excel Français..... "Feuil1" ne sera reconnu dans aucune autre version, nous avons des "Sheet1", "Hoja1", j'en passe et des meilleures

Mais les deux solutions sont bonnes

Cordialement

Yurperqod · 29 Juillet 2016

Suite bis

•>Efgé
En tenant compte de ta dernière remarque

VB:

Sub testC()
Dim Chemin As String, NomFichier As String, NouvClass As Workbook
Workbooks.Add (1): Set NouvClass = ActiveWorkbook: ThisWorkbook.Activate
Chemin = ThisWorkbook.Path & "\"
NomFichier = ThisWorkbook.Sheets("Saisie").Range("P5").Text
Sheets.Select: Sheets.Copy After:=NouvClass.Sheets(1)
Application.DisplayAlerts = False
Sheets(Array(1, 2, 3)).Delete
NouvClass.SaveAs Chemin & NomFichier & ".xlsx", 51: NouvClass.Close True
End Sub

Déplacer toutes les feuilles après la 2ème dans un nouveau classeur

philippe_chalon01

XLDnaute Nouveau

Pièces jointes

Alza

XLDnaute Junior

philippe_chalon01

XLDnaute Nouveau

Efgé

XLDnaute Barbatruc

philippe_chalon01

XLDnaute Nouveau

Yurperqod

XLDnaute Occasionnel

Efgé

XLDnaute Barbatruc

philippe_chalon01

XLDnaute Nouveau

philippe_chalon01

XLDnaute Nouveau

Yurperqod

XLDnaute Occasionnel

Efgé

XLDnaute Barbatruc

Yurperqod

XLDnaute Occasionnel

Efgé

XLDnaute Barbatruc

Yurperqod

XLDnaute Occasionnel

Discussions similaires