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

philippe_chalon01

XLDnaute Nouveau
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
 

Pièces jointes

  • Fichier essai.xlsm
    78.2 KB · Affichages: 55
Dernière édition:

Yurperqod

XLDnaute Occasionnel
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é

XLDnaute Barbatruc
Re à tous
Comme Yurperqod en pas pareil
(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

XLDnaute Nouveau
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
 

Yurperqod

XLDnaute Occasionnel
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
 

Yurperqod

XLDnaute Occasionnel
Bonjour Efgé

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)
 

Yurperqod

XLDnaute Occasionnel
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
 

Discussions similaires

Statistiques des forums

Discussions
311 711
Messages
2 081 799
Membres
101 818
dernier inscrit
tiftouf5757