Votre question
Résolu

Macro excel pour créer des classeurs à partir des feuilles selon le nom

Tags :
  • Microsoft Excel
  • Programmation
Dernière réponse : dans Programmation
10 Août 2016 23:58:47

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)

Merci d'avance !!

  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

Autres pages sur : macro excel creer classeurs partir feuilles nom

a b L Programmation
11 Août 2016 07:24:03

Salut,
Quel est ta question exactement ?
m
0
l
11 Août 2016 10:17:39

drul a dit :
Salut,
Quel est ta question exactement ?


J'ai fichier excel (classeur) contenant plusieurs sheet , je voudrais découper ce dernier en plusieurs nouveaux classeur
Voici un exemple:
Le classeur agregate contient 8 sheets : A.1, A.2, A.3, A.4 ,B.1, B.2, B.3 et B.4
je voudrais créer 4 nouveaux classeur Book1, Book2, Book3 et Book4
Book1 contenant les sheets A.1 et B.1
Book2 contenant les sheets A.2 et B.2
Book3 contenant les sheets A.3 et B.3 et ainsi de suite

Le code que j'ai actuellement decoupe le fichier aggregate en autant de sheet présente dans celui-ci donc j'obtient 8 nouveaux classeurs Book1, Book2, Book3 ....... jusqu'a 8.
Ma question est de savoir ce que je dois modifier dans mon code pour arriver au resultat voulu.

Merci
m
0
l
Contenus similaires
a b L Programmation
11 Août 2016 10:59:42

Re,
alors t'en es pas trop loin ;) 
Je te met ici la (une) solution pour les ".1" je te laisserai faire le boulot pour les autres ...
P.S. jette un oeil aux 2 commentaires.
P.S.2 il y avait aussi une ou deux erreur sur la gestion des noms de fichiers (je me retrouvais avec des fichiers sans extension)

  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.  
  17. myString = ws.Name
  18. If InStr(myString, ".1") > 0 Then
  19. If wb2 Is Nothing Then
  20. ws.Copy
  21. Set wb2 = ActiveWorkbook
  22. sPath2 = sPath1 & Application.PathSeparator & ws.Name & ".xlsx" 'Es-tu sûr de vouloir donné as ton fichier de recap des .1 les nom de la première feuille .1 rencontré ?
  23. Else
  24. ws.Copy after:=wb2.Sheets(wb2.Sheets.Count)
  25. End If
  26.  
  27. End If
  28.  
  29.  
  30. End If
  31. Next
  32. On Error Resume Next 'pas fan de cette façon de faire, dans l'ideal tu devrais plutot voir si le fichier existe (et n'est pas ouvert)
  33. Kill sPath2
  34. On Error GoTo 0
  35. Call wb2.SaveAs(sPath2, xlOpenXMLWorkbook)
  36. Call wb2.Close(False)
  37.  
  38. wb1.Activate
  39. Application.ScreenUpdating = true
  40. End Sub
m
0
l
11 Août 2016 11:40:04

drul a dit :
Re,
alors t'en es pas trop loin ;) 
Je te met ici la (une) solution pour les ".1" je te laisserai faire le boulot pour les autres ...
P.S. jette un oeil aux 2 commentaires.
P.S.2 il y avait aussi une ou deux erreur sur la gestion des noms de fichiers (je me retrouvais avec des fichiers sans extension)

  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.  
  17. myString = ws.Name
  18. If InStr(myString, ".1") > 0 Then
  19. If wb2 Is Nothing Then
  20. ws.Copy
  21. Set wb2 = ActiveWorkbook
  22. sPath2 = sPath1 & Application.PathSeparator & ws.Name & ".xlsx" 'Es-tu sûr de vouloir donné as ton fichier de recap des .1 les nom de la première feuille .1 rencontré ?
  23. Else
  24. ws.Copy after:=wb2.Sheets(wb2.Sheets.Count)
  25. End If
  26.  
  27. End If
  28.  
  29.  
  30. End If
  31. Next
  32. On Error Resume Next 'pas fan de cette façon de faire, dans l'ideal tu devrais plutot voir si le fichier existe (et n'est pas ouvert)
  33. Kill sPath2
  34. On Error GoTo 0
  35. Call wb2.SaveAs(sPath2, xlOpenXMLWorkbook)
  36. Call wb2.Close(False)
  37.  
  38. wb1.Activate
  39. Application.ScreenUpdating = true
  40. End Sub


Merci beaucoup
J'ai juste un dernier petit souci
  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.  
  17. myString = ws.Name
  18. If InStr(myString, ".1") > 0 Then
  19. If wb2 Is Nothing Then
  20. ws.Copy
  21. Set wb2 = ActiveWorkbook
  22. sPath2 = sPath1 & Application.PathSeparator & ws.Name & ".xlsx"
  23. Else
  24. ws.Copy after:=wb2.Sheets(wb2.Sheets.Count)
  25. End If
  26.  
  27. End If
  28.  
  29.  
  30. End If
  31. Next
  32. On Error Resume Next
  33. Kill sPath2
  34. On Error GoTo 0
  35. Call wb2.SaveAs(sPath2, xlOpenXMLWorkbook)
  36. Call wb2.Close(False)
  37.  
  38. For Each ws In wb2.Worksheets
  39. If ws.Visible Then
  40.  
  41. myString = ws.Name
  42. If InStr(myString, ".2") > 0 Then
  43. If wb3 Is Nothing Then
  44. ws.Copy
  45. Set wb3 = ActiveWorkbook
  46. sPath3 = sPath2 & Application.PathSeparator & ws.Name & ".xlsx"
  47. Else
  48. ws.Copy after:=wb3.Sheets(wb3.Sheets.Count)
  49. End If
  50.  
  51. End If
  52.  
  53.  
  54. End If
  55. Next
  56. On Error Resume Next
  57. Kill sPath3
  58. On Error GoTo 0
  59. Call wb3.SaveAs(sPath3, xlOpenXMLWorkbook)
  60. Call wb3.Close(False)
  61.  
  62. wb1.Activate
  63. Application.ScreenUpdating = True
  64. End Sub


Quand je veut le faire pour les fichiers ".2" le code me dit qu'il y a une erreur. Peut être est ce moi qui est mal compris ?
m
0
l
a b L Programmation
11 Août 2016 13:07:45

Nah mais faut pas refaire une boucle for each, utilise celle que tu as déjà !

  1. Sub SplitSheets()
  2. Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook, wb4 As Workbook, wb5 As Workbook
  3. Dim ws As Worksheet
  4. Dim myString As String
  5. Dim sPath1 As String, sPath2 As String, sPath3 As String, sPath4 As String, sPath5 As String
  6.  
  7. Set wb1 = ThisWorkbook
  8. sPath1 = wb1.Path
  9.  
  10. Application.ScreenUpdating = False
  11.  
  12.  
  13. For Each ws In wb1.Worksheets
  14. If ws.Visible Then
  15.  
  16. myString = ws.Name
  17. If InStr(myString, ".1") > 0 Then
  18. If wb2 Is Nothing Then
  19. ws.Copy
  20. Set wb2 = ActiveWorkbook
  21. sPath2 = sPath1 & Application.PathSeparator & ws.Name & ".xlsx"
  22. Else
  23. ws.Copy after:=wb2.Sheets(wb2.Sheets.Count)
  24. End If
  25.  
  26. ElseIf InStr(myString, ".2") > 0 Then
  27. If wb3 Is Nothing Then
  28. ws.Copy
  29. Set wb3 = ActiveWorkbook
  30. sPath3 = sPath2 & Application.PathSeparator & ws.Name & ".xlsx"
  31. Else
  32. ws.Copy after:=wb3.Sheets(wb3.Sheets.Count)
  33. End If
  34.  
  35. End If
  36.  
  37. End If
  38. Next
  39. On Error Resume Next
  40. Kill sPath2
  41. Kill sPath3
  42. On Error GoTo 0
  43.  
  44. Call wb2.SaveAs(sPath2, xlOpenXMLWorkbook)
  45. Call wb2.Close(False)
  46.  
  47. Call wb3.SaveAs(sPath3, xlOpenXMLWorkbook)
  48. Call wb3.Close(False)
  49.  
  50. wb1.Activate
  51. Application.ScreenUpdating = True
  52. End Sub
m
0
l
11 Août 2016 13:13:37

drul a dit :
Nah mais faut pas refaire une boucle for each, utilise celle que tu as déjà !

  1. Sub SplitSheets()
  2. Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook, wb4 As Workbook, wb5 As Workbook
  3. Dim ws As Worksheet
  4. Dim myString As String
  5. Dim sPath1 As String, sPath2 As String, sPath3 As String, sPath4 As String, sPath5 As String
  6.  
  7. Set wb1 = ThisWorkbook
  8. sPath1 = wb1.Path
  9.  
  10. Application.ScreenUpdating = False
  11.  
  12.  
  13. For Each ws In wb1.Worksheets
  14. If ws.Visible Then
  15.  
  16. myString = ws.Name
  17. If InStr(myString, ".1") > 0 Then
  18. If wb2 Is Nothing Then
  19. ws.Copy
  20. Set wb2 = ActiveWorkbook
  21. sPath2 = sPath1 & Application.PathSeparator & ws.Name & ".xlsx"
  22. Else
  23. ws.Copy after:=wb2.Sheets(wb2.Sheets.Count)
  24. End If
  25.  
  26. ElseIf InStr(myString, ".2") > 0 Then
  27. If wb3 Is Nothing Then
  28. ws.Copy
  29. Set wb3 = ActiveWorkbook
  30. sPath3 = sPath2 & Application.PathSeparator & ws.Name & ".xlsx"
  31. Else
  32. ws.Copy after:=wb3.Sheets(wb3.Sheets.Count)
  33. End If
  34.  
  35. End If
  36.  
  37. End If
  38. Next
  39. On Error Resume Next
  40. Kill sPath2
  41. Kill sPath3
  42. On Error GoTo 0
  43.  
  44. Call wb2.SaveAs(sPath2, xlOpenXMLWorkbook)
  45. Call wb2.Close(False)
  46.  
  47. Call wb3.SaveAs(sPath3, xlOpenXMLWorkbook)
  48. Call wb3.Close(False)
  49.  
  50. wb1.Activate
  51. Application.ScreenUpdating = True
  52. End Sub


Ahhh mais oui bien sur
merci bcp pour ton aide :) 
m
0
l

Meilleure solution

a b L Programmation
11 Août 2016 13:26:20

N.B.
Tu as un cas assez particulier ici, qui permet de considérablement simplifier le code, puisque tu fais 4 fois la même chose:

  1. Sub SplitSheets()
  2. Dim wb(5) As Workbook
  3. Dim ws As Worksheet
  4. Dim myString As String
  5. Dim sPath(5) As String
  6. Dim i As Integer
  7. Set wb(0) = ThisWorkbook
  8. sPath(0) = wb(0).Path
  9.  
  10. Application.ScreenUpdating = False
  11.  
  12.  
  13. For Each ws In wb(0).Worksheets
  14. If ws.Visible Then
  15. myString = ws.Name
  16. For i = 1 To 4
  17.  
  18. If InStr(myString, "." & i) > 0 Then
  19. If wb(i) Is Nothing Then
  20. ws.Copy
  21. Set wb(i) = ActiveWorkbook
  22. sPath(i) = sPath(0) & Application.PathSeparator & ws.Name & ".xlsx"
  23. Else
  24. ws.Copy after:=wb(i).Sheets(wb(i).Sheets.Count)
  25. End If
  26.  
  27. End If
  28. Next
  29. End If
  30. Next
  31. For i = 1 To 4
  32. If sPath(i) <> "" Then
  33. On Error Resume Next
  34. Kill sPath(i)
  35. On Error GoTo 0
  36.  
  37. Call wb(i).SaveAs(sPath(i), xlOpenXMLWorkbook)
  38. Call wb(i).Close(False)
  39. End If
  40. Next
  41.  
  42. wb(0).Activate
  43. Application.ScreenUpdating = True
  44. End Sub
partage
11 Août 2016 16:48:47

drul a dit :
N.B.
Tu as un cas assez particulier ici, qui permet de considérablement simplifier le code, puisque tu fais 4 fois la même chose:

  1. Sub SplitSheets()
  2. Dim wb(5) As Workbook
  3. Dim ws As Worksheet
  4. Dim myString As String
  5. Dim sPath(5) As String
  6. Dim i As Integer
  7. Set wb(0) = ThisWorkbook
  8. sPath(0) = wb(0).Path
  9.  
  10. Application.ScreenUpdating = False
  11.  
  12.  
  13. For Each ws In wb(0).Worksheets
  14. If ws.Visible Then
  15. myString = ws.Name
  16. For i = 1 To 4
  17.  
  18. If InStr(myString, "." & i) > 0 Then
  19. If wb(i) Is Nothing Then
  20. ws.Copy
  21. Set wb(i) = ActiveWorkbook
  22. sPath(i) = sPath(0) & Application.PathSeparator & ws.Name & ".xlsx"
  23. Else
  24. ws.Copy after:=wb(i).Sheets(wb(i).Sheets.Count)
  25. End If
  26.  
  27. End If
  28. Next
  29. End If
  30. Next
  31. For i = 1 To 4
  32. If sPath(i) <> "" Then
  33. On Error Resume Next
  34. Kill sPath(i)
  35. On Error GoTo 0
  36.  
  37. Call wb(i).SaveAs(sPath(i), xlOpenXMLWorkbook)
  38. Call wb(i).Close(False)
  39. End If
  40. Next
  41.  
  42. wb(0).Activate
  43. Application.ScreenUpdating = True
  44. End Sub


Super c'est ce qu'il me fallait !!
merci !!
m
0
l
a b L Programmation
11 Août 2016 20:40:04

si tu es satisfait, alors clos le sujet stp
m
0
l