Sauvegarde de plusieurs feuilles dans un nouveau classeur par département

[KIM]

Bonjour les ami(e)s et le forum,
J'ai essayé plusieurs techniques de sauvegarde du forum. J'ai réussi à sauvegarder feuille par feuille mais je n'ai pas pu sauvegarder un ensemble de feuilles dans un nouveau classeur par département. Je vous remercie de votre aide.
En effet Selon les types de données sources, j'ai pu créer des fichiers correspondants par type de sources et par Département. Les feuilles sont nommées par le nom du département sur 4 car suivi du type des données sources (ex DP01_R_Surf). J'en ai au moins 120 feuilles. Je souhaite sauvegarder les feuilles de chaque département dans un classeur du nom du département (Ex: Dans le classeur DP01.xls je souhaite retrouver toutes les feuilles dont les noms commencent par le meme nom departement avec la feuille Aide). La feuille "Aide" sera copiée dans chaque nouveau classeur du nom du département. Voir fichier ci-joint
Merci encore
KIM

 

[Softmama]

Re : Sauvegarde de plusieurs feuilles dans un nouveau classeur par département

Bonsoir KIM,

Vois si le fichier joint en retour effectue bien ce que tu souhaites. Macro ici :

Sub VoyonsCa()
Dim nFich$, nFLong$, nOnglet$, t&
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For t = 1 To ActiveWorkbook.Sheets.Count
    If Left$(Sheets(t).Name, 2) = "DP" Then
        nFich = "DP" & Mid(Sheets(t).Name, 3, 2)
        nFLong = ActiveWorkbook.Path & "\" & nFich & ".xls"
        If Dir(nFLong) = "" Then
            ActiveWorkbook.SaveCopyAs Filename:=nFLong
            Application.Workbooks.Open (nFLong)
            Sheets("Menu").Delete
            For u = ActiveWorkbook.Sheets.Count To 1 Step -1
                nOnglet = Sheets(u).Name
                If UCase(Left$(nOnglet, 4)) <> UCase(Left$(ActiveWorkbook.Name, 4)) And nOnglet <> "Aide" Then Sheets(u).Delete
            Next
            ActiveWorkbook.Close True
        End If
    End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

La macro scanne les onglets. Dès qu'elle en trouve un qui commence par DP+N° de département sur 2 octets, elle vérifie qu'elle ne l'a pas déjà traité en vérifiant si y a pas dans le répertoire courant de fichier qui porte le même nom. A ce moment, elle vire les onglets qui ne concernent pas le dpt qu'il faut avant de le sauvegarder et de passer à l'onglet suivant.

Télécharger

 

[KIM]

Re : Sauvegarde de plusieurs feuilles dans un nouveau classeur par département

Bonsoir Softmama, bonsoir le forum,
Merci, la macro répond bien à ma demande. Par contre, après lancement de la macro :
1- je ne peux pas ouvrir les fichiers créés par Departement si je ne ferme pas le classeur initial? Pourquoi?
2- Est-il possible que la sauvegarde se fasse sans les macros du initial et sans les formules dans les feuilles, seulement les valeurs?
3- Est-il possible de sauvegarder les fichiers des départements dans un répertoire nommé "RECAP_DP" du répertoire courant?

Merci d'avance pour ton aide.
Bonne soirée
KIM

 

[Softmama]

Re : Sauvegarde de plusieurs feuilles dans un nouveau classeur par département

Re,

1- Bizarre ! Je suis dsl mais cela doit venir de ton environnement, car je ne rencontre pas le pb ici.

2- Pour virer macro :
Ajoute cette ligne

ActiveWorkbook.VBProject.VBComponents.Remove ActiveWorkbook.VBProject.VBComponents.Item("Module1")

avant :

ActiveWorkbook.Close True

2bis- Pour garder que valeurs, remplace cette ligne :

If UCase(Left$(nOnglet, 4)) <> UCase(Left$(ActiveWorkbook.Name, 4)) And nOnglet <> "Aide" Then Sheets(u).Delete

par

If UCase(Left$(nOnglet, 4)) <> UCase(Left$(ActiveWorkbook.Name, 4)) And nOnglet <> "Aide" Then Sheets(u).Delete Else Sheets(u).UsedRange = Sheets(u).UsedRange.Value

3- Pour sauvegarder dans Répertoire Recap_DP, ajoute :

If Dir(ActiveWorkbook.Path & "\" & "RECAP_DP\", vbDirectory) = "" Then MkDir (ActiveWorkbook.Path & "\" & "RECAP_DP\")

Avant :

For t=1 to...

La macro totale est devenue comme ceci :

Sub VoyonsCa()
Dim nFich$, nFLong$, nOnglet$, t&
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If Dir(ActiveWorkbook.Path & "\" & "RECAP_DP\", vbDirectory) = "" Then MkDir (ActiveWorkbook.Path & "\" & "RECAP_DP\")
For t = 1 To ActiveWorkbook.Sheets.Count
    If Left$(Sheets(t).Name, 2) = "DP" Then
        nFich = "DP" & Mid(Sheets(t).Name, 3, 2)
        nFLong = ActiveWorkbook.Path & "\" & nFich & ".xls"
        If Dir(nFLong) = "" Then
            ActiveWorkbook.SaveCopyAs Filename:=nFLong
            Application.Workbooks.Open (nFLong)
            Sheets("Menu").Delete
            For u = ActiveWorkbook.Sheets.Count To 1 Step -1
                nOnglet = Sheets(u).Name
                If UCase(Left$(nOnglet, 4)) <> UCase(Left$(ActiveWorkbook.Name, 4)) And nOnglet <> "Aide" Then Sheets(u).Delete Else Sheets(u).UsedRange = Sheets(u).UsedRange.Value
            Next
            ActiveWorkbook.VBProject.VBComponents.Remove ActiveWorkbook.VBProject.VBComponents.Item("Module1")
            ActiveWorkbook.Close True
        End If
    End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Je te laisse tester...

 

[Softmama]

Re : Sauvegarde de plusieurs feuilles dans un nouveau classeur par département

Re,

ça m'apprendra à pas tester mes modifs... Je viens de réaliser que j'ai oublié de modifier le chemin pour sauvegarder les fichiers afin de répondre correctement à ton attente du 3-
Aussi, remplace dans la macro, la ligne

        nFLong = ActiveWorkbook.Path & "\" & nFich & ".xls"

par

        nFLong = ActiveWorkbook.Path & "\RECAP_DP\" & nFich & ".xls"

 

[KIM]

Re : Sauvegarde de plusieurs feuilles dans un nouveau classeur par département

Re,
Merci pour tes réponses rapides. En effet:
1- J'ai toujours le même blocage. De même je ne peux pas lancer une 2ième fois la macro tant que le répertoire de sauvegarde n'est pas vide.
2- la suppression du module "Module1" se fait bien. Par contre j'ai une dizaine de modules, est-ce que je dois dupliquer le code de suppression de module autant de fois de modules à supprimer ou y a t il une commande generale pour supprimer tous les modules du
VBProject
Merci d'avance
KIM

 

[Softmama]

Re : Sauvegarde de plusieurs feuilles dans un nouveau classeur par département

Bonjour,

Re,
1- J'ai toujours le même blocage. De même je ne peux pas lancer une 2ième fois la macro tant que le répertoire de sauvegarde n'est pas vide.
KIM

1- Il est normal que si les fichiers existent déjà, la macro ne gère pas l'onglet concerné : elle a été créée pour ça. Pour le reste, je n'ai pas de pb chez moi.

Re,
2- la suppression du module "Module1" se fait bien. Par contre j'ai une dizaine de modules, est-ce que je dois dupliquer le code de suppression de module autant de fois de modules à supprimer ou y a t il une commande generale pour supprimer tous les modules du VBProject
KIM

Tu peux remplacer la ligne avec "Module1" par :

For i = Thisworkbook.VBProject.VBComponents.Count To 1 Step -1
    If Thisworkbook.VBProject.VBComponents.Item(i).Type = 1 Then Thisworkbook.VBProject.VBComponents.Remove Thisworkbook.VBProject.VBComponents.Item(i)
Next i

 

[KIM]

Re : Sauvegarde de plusieurs feuilles dans un nouveau classeur par département

Bonjour Softmama, & le forum,
Merci pour l'aide et les conseils,
J'ai remplacé Thisworkbook.VBProject.VBComponents.Count To 1 Step -1
par Activeworkbook.VBProject.VBComponents.Count To 1 Step -1
car avec Thisworkbook.etc., il supprime les macros du fichier initial.

Merci encore,
Il me reste le blocage de la macro de regroupement des feuilles par Département dans un nouveau classeur. J'ai plusieurs macros, c'est la seule macro qui bloque. Je continue mon exploration et te tiens au courant.
Bonne journée
KIM