Votre question
Fermé

Macro Excel pour créer classeurs à partir de feuilles

Tags :
  • Programmation
  • VB
Dernière réponse : dans Programmation
9 Décembre 2009 18:44:06

Bonjour,

mes recherches étant resté vaines sur le sujet, je sollicite votre aide.

voila mon pb:
Je reçois tous les mois un fichier Excel contenant de 5 à 40 feuilles.
Je dois l'éclater en autant de classeurs que de feuilles :
ex:
j'ai un classeur "monclasseur" contenant les feuilles AAAA, BBBB et CCCC
je souhaiterais créer 1 classeur nommé AAAA avec la feuille AAAA
un autre nommé BBBB avec la feuille BBBB
et enfin un autre nommé CCCC avec la feuille CCCC

merci donc pour votre aide à la réalisation de cette macro,

Cordialement,

Autres pages sur : macro excel creer classeurs partir feuilles

10 Décembre 2009 11:20:04

Bonjour,

Voici un code vite-fait qui fait ça, il n'y a pas de gestion des erreurs, il faudra peut l'adapter à ton cas :

  1. Sub Macro2()
  2. For Each feuille In ActiveWorkbook.Sheets
  3. Set newBook = Workbooks.Add
  4. With newBook
  5. .Title = feuille.Name
  6. .Subject = feuille.Name
  7. .SaveAs Filename:=feuille.Name + ".xls"
  8. End With
  9.  
  10. Next


Voila j'espère t'avoir aidé.
Score
0
10 Décembre 2009 12:14:26

Bonjour,

Merci pour cette réponse rapide;

La création des classeurs avec les noms des feuilles fonctionne très bien.

Par contre, la copie de la feuille en question n'est pas réalisée dans le nouveau classeur.

Cette fonction me ferait gagner enormément de temps;

Encore merci

Cordialement,
Score
0
Contenus similaires
10 Décembre 2009 12:22:03

Pardon, j'avais mal lu, voici :

  1. Sub Macro2()
  2.  
  3. For Each feuille In ActiveWorkbook.Sheets
  4. feuille.Copy
  5. With ActiveWorkbook
  6. .Title = feuille.Name
  7. .Subject = feuille.Name
  8. .SaveAs Filename:=feuille.Name + ".xls"
  9. End With
  10.  
  11. Next
  12. End Sub

Score
0
10 Décembre 2009 13:04:03

Merci beaucoup,

c'est super.

C'est précisément ce que je souhaitais.

cela va m'aider considérablement;

Cordialement, :hello: 
Score
0
27 Août 2012 15:00:28



je suis novice
pouvez-vous m'envoyer le fichier avec un bouton pour la macro?
merci
Score
0
a b L Programmation
28 Août 2012 09:36:20

Bonjour Youcefe,

Non pas question. Nous ne faisons pas d'échange de fichiers.
C'est à ce prix que nous nous préservons des virus.
Score
0
27 Janvier 2014 16:53:11

Hello hello,

Je viens de tomber sur cette macro qui marche plutôt bien, même très bien, voire trop bien dans mon cas.

Comment est-ce que l'on fait pour ne copier que le contenu de la page courante?

J'imagine qu'il faut modifier la condition For Each feuille In ActiveWorkbook.Sheets mais j'ai jamais fait de VBA avant et je connais pas les fonctions

Merci d'avance et je m'excuse de ressusciter le topic :o 
Score
0
a b L Programmation
28 Janvier 2014 10:56:14

Cher MagicVtalic,

Les topics ne sont pas fermés automatiquement, pour qu'on puisse au besoin les "ressusciter".
Tu es donc le bienvenu.

--------------

Tu as donc ouvert un classeur pleins de feuilles et tu voudrais enregistrer la feuille courante dans un classeur à part.
C'est bien ça ?

Facile !
  1. ActiveSheet.SaveAs Filename:=ActiveSheet.Name & ".xls"


Il convient maintenant de vérifier que le fichier n'existe pas, qu'on est bien dans le répertoire voulu, etc.
On continue ?
Score
0
28 Janvier 2014 11:09:43

Hello hello!

C'est trop cool! c'est parfait!

Et au lieu de l'affecter à un bouton que je dois copier/coller dans chaque feuille, je peux l'ajouter en barre d'accès rapide. C'est surpuissant!

Merci Zeb :) 
Score
0
a b L Programmation
28 Janvier 2014 11:15:23

Mais de rien. Donc pas de problème de répertoire, de fichier déjà présent !
Score
0
28 Janvier 2014 11:30:10

Non, en bidouillant le nom du nouveau fichier, j'arrive à ne pas créer d'erreur.
Mais sije veux lui dire de sauvegarder cette nouvelle feuille dans un répertoire qui se trouve au même niveau que le fichier dans lequel je me trouve. Qu'est-ce que je peux lui dire?
Score
0
a b L Programmation
28 Janvier 2014 14:13:12

Le classeur ouvert et actif est représenté par l'objet ActiveWorkbook.
Tu peux te servir de sa propriété FullName qui contient le chemin et le nom du fichier.

Regarde. Je ne retire que l'extension (pour la remettre plus tard) mais j'ajoute le nom de la feuille à la fin du nom du classeur. Mal mal, non ? Je rajoute un éventuel compteur (N) pour être sûr de ne pas écraser un précédent fichier :
  1. Dim FSO As New FileSystemObject
  2. Dim sExt As String
  3. Dim sRootFN As String
  4. Dim N As Integer
  5. Dim sFullFN As String
  6.  
  7. sExt = fso.GetExtensionName(ActiveWorkBook.Fullname)
  8. sRootFN = Left(ActiveWorkBook.Fullname, Len(sExt)-1) & "_" & ActiveSheet.Name
  9.  
  10. N = 0
  11. Do
  12. sFullFN = sRootFN & Iif(N = 0, "", "_" & N) & "." & sExt
  13. N = N + 1
  14. Loop While FSO.FileExists(sFullFN)
  15.  
  16. ActiveSheet.SaveAs Filename:=sFullFN



Si FileSystemObject ne fait pas partie de tes références dans Excel, alors la première ligne doit être remplacée par :
  1. Dim fso As Object
  2. Set fso = CreateObject("Scripting.FileSystemObject")
Score
0
a b L Programmation
28 Janvier 2014 15:23:35

Hello,
Remarque, on peut également faire ça avec l'aide de activeworkbook.path et de la commande dir
Score
0
a b L Programmation
28 Janvier 2014 17:48:46

Salut mon cher Drul
:hello: 

+1 pour la méthode Path.

Mais oulala que je n'aime pas la commande Dir(), pleine de fuites mémoire.
Et comment fais-tu pour savoir si le fichier existe, sachant qu'il est interdit de répondre "Je déclenche une exception" ?
Score
0
a b L Programmation
28 Janvier 2014 17:53:12

Oups, la commande Dir() renvoie une chaîne vide si le fichier n'existe pas.
Donc pas de problème avec la gestion des erreurs. Les fuites mémoires restent vraies.
Score
0
a b L Programmation
28 Janvier 2014 19:52:57

Re-Salut maître Zeb [:coucou],
Je ne savais pas pour les fuites mémoires, je l'ai souvent utilisé sans soucis.
Score
0
a b L Programmation
29 Janvier 2014 08:52:38

En fait, Dir() lit tout le contenu du répertoire et stocke le tout dans des variables globales.
Utiliser cette fonction en VBA dans une petite macro ne porte pas à conséquence.
Il n'en va pas de même dans une grosse application développée en Visual Basic.

D'où mon aversion pour cette fonction. Mais je ne t'empêche pas de l'utiliser, ni même de la proposer à MagicVitalic ;) 
Score
0
29 Janvier 2014 14:10:32

Merci pour ton intervention Drul :) 

Je pourrais intégrer Dir() comment alors, dans ma fonction?
Score
0
a b L Programmation
29 Janvier 2014 14:41:32

Un exemple (avec un peu de récursivité, parce qu'il faut bien s'amuser ;) )
  1. Sub MaSub()
  2. savesheet (0)
  3. End Sub
  4. Sub savesheet(index As Integer)
  5. Dim TargetName As String
  6. TargetName = ActiveWorkbook.Path & "\" & ActiveSheet.Name & "_" & index & ".xls"
  7. If Dir(TargetName) = "" Then
  8. ActiveSheet.SaveAs Filename:=TargetName
  9. Else
  10. savesheet (index + 1)
  11. End If
  12. End Sub

Tu dois faire un appel a MaSub()
Le résultat doit être assez proche de celui de Zeb.
Score
0
a b L Programmation
30 Janvier 2014 14:19:53

(Sauf que moi, je ne numérote pas le premier :sol:  )

Retire les parenthèses dans les appels à SaveSheet.
Oui, je sais c'est moche le VB :( 
Score
0
a b L Programmation
30 Janvier 2014 15:32:41

Rappel moi la différence, j'oublie tout le temps ... :pt1cable: 
Score
0
a b L Programmation
31 Janvier 2014 08:51:23

Il n'y a juste pas à mettre de parenthèse. :o 

------------

Exemple :
  1. Sub Sub1(index As Integer)
  2. MsgBox "La procédure est Sub1(Integer)" & vbCrLf & "Le paramètre est " & index
  3. End Sub
  4.  
  5. Sub Sub2(index As Integer, prm2 As String)
  6. MsgBox "La procédure est Sub2(Integer, String)" & vbCrLf & "Les paramètres sont " & index & " et """ & prm2 & """"
  7. End Sub
  8.  
  9. ...
  10. ' // Ok
  11. Sub1 (1)
  12.  
  13. ' // Marche pas !
  14. Sub2 (2, "Drul")


Dans le premier cas, les parenthèses sont vues par VB comme opérateur d'ordre de priorité arithmétique :
1 + 2 x 3 = 7
(1+2) x 3 = 9

L'erreur est de croire que ces parenthèses délimitaient les paramètres.
Stou. :spamafote: 
Score
0
a b L Programmation
31 Janvier 2014 09:04:10

:jap: 
Score
0
31 Janvier 2014 10:22:08

Salut les loulous,

J'ai repris vos deux fonctions telles quelles
Citation :
Sub MaSub()
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim sExt As String
Dim sRootFN As String
Dim N As Integer
Dim sFullFN As String

sExt = fso.GetExtensionName(ActiveWorkbook.FullName)
sRootFN = Left(ActiveWorkbook.FullName, Len(sExt) - 1) & "_" & ActiveSheet.Name

N = 0
Do
sFullFN = sRootFN & IIf(N = 0, "", "_" & N) & "." & sExt
N = N + 1
Loop While fso.FileExists(sFullFN)

ActiveSheet.SaveAs Filename:="animation_HP-jeu-mobile_2014_" + ActiveSheet.Name + ".xls"
End Sub


et

Citation :
Sub MaSub()
savesheet (0)
End Sub
Sub savesheet(index As Integer)
Dim TargetName As String
TargetName = ActiveWorkbook.Path & "\" & ActiveSheet.Name & "_" & index & ".xls"
If Dir(TargetName) = "" Then
ActiveSheet.SaveAs Filename:="animation_HP-jeu-mobile_2014_" + ActiveSheet.Name + ".xls"
End Sub


Mais dans les deux cas, j'ai deux soucis
- il me sauvegarde l'intégralité de mon document et non la feuille active
- il ne me sauvegarde pas ça dans dossier dans lequel le classeur est, mais dans mon dossier Mes Documents

C'est grave Docteur?
-
Score
0
a b L Programmation
31 Janvier 2014 11:30:15

Salut MV,
on a oublié le "ActiveSheet.Copy", avant de faire "ActiveSheet.SaveAs ..."
  1. ...
  2. ActiveSheet.Copy
  3. ActiveSheet.SaveAs Filename:=TargetName
  4. ...

Quand à la sauvegarde dans le dossier mesDoc, c'est logique, tu as virer toute la partie intéressante de notre code, celle qui récupère le path, et évite un écrasement de l'ancien fichier en incrémentant un index dans le nom du fichier !
Si comme j'en ai l'impression, tu t'en fou et que tu veux juste sauver ta feuille sans vérif, alors:

  1. Sub savesheet()
  2. Dim TargetName As String
  3. TargetName = ActiveWorkbook.Path & "\animation_HP-jeu-mobile_2014_" + ActiveSheet.Name + ".xls"
  4. ActiveSheet.Copy
  5. ActiveSheet.SaveAs Filename:=TargetName
  6. End Sub
Score
0
a b L Programmation
3 Février 2014 15:45:29

:lol: 
Score
0
a b L Programmation
3 Février 2014 15:53:43

Tiens Zeb vu que je t'ai sous la main, y a t'il une différence entre
  1. MyStr = "Hahaha" + "Hihihi"

et
  1. MyStr = "Hahaha" & "Hihihi"

?
Score
0
a b L Programmation
3 Février 2014 16:20:34

Euh... & c'est l'opérateur de concaténation, + c'est l'opérateur d'addition.
VB est plutôt laxiste, alors il acceptera + pour & s'il n'y a pas ambiguïté.
Mais attention avec des trucs comme ça :

  1. YourStr = "DR"+1+"L"
  2. YourStr = "DR"+1+2
  3. YourStr = 1+2+"UL"


Bref, il vaut mieux toujours définir les types de variables (pas de variant), utiliser l'option explicite, et faire soi-même les bons trans-typages.
Les fonctions CInt(), CLng() etc. sont là pour ça.
Score
0

Meilleure solution

27 Avril 2015 18:01:06

Bonjour à tous,

Je viens d'utiliser le code créé par tantal_fr le 10/12/2009. Il m'a été très utile et je remercie donc au passage son auteur (s'il revient un jour par ici, sait-on jamais...).

En revanche, étant donné que j'avais un très gros fichier (14 Mo) avec plus de 50 onglets, l'exécution de la macro a fini par saturer la RAM de mon PC. Finalement, ça a marché, mais cela a mis très longtemps et j'ai bien cru que tout avait planté !

En fait, cela venait tout simplement du fait que, dans cette macro, les fichiers nouvellement créés restent ouverts. Afin de remédier à cela, j'ai ajouté "ActiveWorkbook.Close" avant le "EndWith". Résultat : c'est beaucoup plus rapide.

Au passage, j'ai aussi modifié le format de fichier (xslx au lieu de xls).

Voici le code ainsi modifié :

  1. Sub Eclater()
  2. For Each feuille In ActiveWorkbook.Sheets
  3. feuille.Copy
  4. With ActiveWorkbook
  5. .Title = feuille.Name
  6. .Subject = feuille.Name
  7. .SaveAs Filename:=feuille.Name + ".xlsx"
  8. ActiveWorkbook.Close
  9. End With
  10. Next
  11. End Sub


En espérant que ce sera utile à d'autres...

Pascal
partage
22 Octobre 2015 22:37:08

Bonsoir à tous !! :) 

Je reprends ce sujet car vous m'avez tous superbement aidée à coder pour créer un classeur à partir d'un existant.

MAIS il me reste deux petits problèmes. Rapidement, je travaille avec un classeur contenant deux feuilles. L'une avec des calculs, l'autre qui les synthétise pour le client. Bien sûr, je ne peux que lui donner la synthèse et pas mes calculs savants.
1. Apparemment, il n'aime pas trop le .xlsm ...
2. Mon bouton d'exécution me pose problème car il se copie aussi sur la synthèse et j'aimerai l'éviter.

Quelqu'un peut-il m'aider s'il vous plait ? Voici le code complet mais je crois qu'il se répète avec mon bouton d'exécution...

Private Sub CommandButton1_Click()
For Each feuille In ActiveWorkbook.Sheets

feuille.Copy

With ActiveWorkbook

.Title = feuille.Name

.Subject = feuille.Name

.ActiveSheet.Copy

.SaveAs Filename:=feuille.Name + ".xlsm"

End With


Next

End Sub

Private Sub Worksheet_Activate()

For Each feuille In ActiveWorkbook.Sheets

feuille.Copy

With ActiveWorkbook

.Title = feuille.Name

.Subject = feuille.Name

.ActiveSheet.Copy

.SaveAs Filename:=feuille.Name + ".xlsm"

End With


Next

End Sub

Merci beaucoup par avance à celui ou celle qui pourra m'aider.


Cordialement.
Score
0
a b L Programmation
23 Octobre 2015 09:14:24


Salut,

Et utilises les balises "code" stp

Après on te répond volontier
Score
0
23 Octobre 2015 10:05:55

drul a dit :

Salut,

Et utilises les balises "code" stp

Après on te répond volontier


Je m'y emploie de ce pas ! Merci :) 
Score
0
10 Août 2016 17:49:19

Bonjour à tous,

Voila mon pb:
j'ai un gros fichier excel contenant plusieurs sheets (+ou- 140 ) , le nom de chaque sheet se termine soit par ".1" , ".2" , ".3" ou ".4".
j'aimeras donc spliter mon fichier excel selon ces caractères donc avoir 4 fichiers: Book.1 (contenant tout les sheets dont les noms se termine par ".1" ) Book.2 ainsi de suite
Au préalable j'ai déja creer 4 fichiers excel .
Voici mon code ( il splite uniquement le fichier excel en autant de sheet présente dans le document donc j'obtient 140 nouveau Workbook)

  1. Option Explicit
  2. Sub SplitSheets()
  3. Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook, wb4 As Workbook, wb5 As Workbook
  4. Dim ws As Worksheet
  5. Dim myString As String
  6. Dim sPath1 As String, sPath2 As String, sPath3 As String, sPath4 As String, sPath5 As String
  7.  
  8. Set wb1 = ThisWorkbook
  9. sPath1 = wb1.Path
  10.  
  11. Application.ScreenUpdating = False
  12.  
  13.  
  14. For Each ws In wb1.Worksheets
  15. If ws.Visible Then
  16. myString = ws.Name
  17. If InStr(myString, ".1") > 0 Then
  18. ws.Copy
  19. Set wb2 = ActiveWorkbook
  20. sPath2 = sPath1 & Application.PathSeparator & ws.Name
  21.  
  22. On Error Resume Next
  23. Kill sPath2 & ".xlsx"
  24. On Error GoTo 0
  25.  
  26. Call wb2.SaveAs(sPath2, xlOpenXMLWorkbook)
  27. Call wb2.Close(False)
  28. End If
  29.  
  30. If InStr(myString, ".2") > 0 Then
  31. ws.Copy
  32. Set wb3 = ActiveWorkbook
  33. sPath3 = sPath1 & Application.PathSeparator & ws.Name
  34.  
  35. On Error Resume Next
  36. Kill sPath3 & ".xlsx"
  37. On Error GoTo 0
  38.  
  39. Call wb3.SaveAs(sPath3, xlOpenXMLWorkbook)
  40. Call wb3.Close(False)
  41. End If
  42.  
  43.  
  44. If InStr(myString, ".3") > 0 Then
  45. ws.Copy
  46. Set wb4 = ActiveWorkbook
  47. sPath4 = sPath1 & Application.PathSeparator & ws.Name
  48.  
  49. On Error Resume Next
  50. Kill sPath4 & ".xlsx"
  51. On Error GoTo 0
  52.  
  53. Call wb4.SaveAs(sPath4, xlOpenXMLWorkbook)
  54. Call wb4.Close(False)
  55. End If
  56.  
  57. If InStr(myString, ".4") > 0 Then
  58. ws.Copy
  59. Set wb5 = ActiveWorkbook
  60. sPath5 = sPath1 & Application.PathSeparator & ws.Name
  61.  
  62. On Error Resume Next
  63. Kill sPath5 & ".xlsx"
  64. On Error GoTo 0
  65.  
  66. Call wb5.SaveAs(sPath5, xlOpenXMLWorkbook)
  67. Call wb5.Close(False)
  68. End If
  69.  
  70. End If
  71. Next
  72.  
  73.  
  74. wb1.Activate
  75. Application.ScreenUpdating = False
  76.  
  77. End Sub
Score
0
a b L Programmation
10 Août 2016 21:39:06

stp.
Score
0
10 Août 2016 23:51:22

ok je vais le faire
Score
0