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

[djedkare]

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 !!

Option Explicit
Sub SplitSheets()
  Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook, wb4 As Workbook, wb5 As Workbook
  Dim ws As Worksheet
  Dim myString As String
  Dim sPath1 As String, sPath2 As String, sPath3 As String, sPath4 As String, sPath5 As String
 
  Set wb1 = ThisWorkbook
  sPath1 = wb1.Path
 
  Application.ScreenUpdating = False
 
 
For Each ws In wb1.Worksheets
    If ws.Visible Then
                myString = ws.Name
                If InStr(myString, ".1") > 0 Then
                ws.Copy
                Set wb2 = ActiveWorkbook
                sPath2 = sPath1 & Application.PathSeparator & ws.Name
 
                On Error Resume Next
                Kill sPath2 & ".xlsx"
                On Error GoTo 0
 
                Call wb2.SaveAs(sPath2, xlOpenXMLWorkbook)
                Call wb2.Close(False)
                End If
 
                If InStr(myString, ".2") > 0 Then
                ws.Copy
                Set wb3 = ActiveWorkbook
                sPath3 = sPath1 & Application.PathSeparator & ws.Name
 
                On Error Resume Next
                Kill sPath3 & ".xlsx"
                On Error GoTo 0
 
                Call wb3.SaveAs(sPath3, xlOpenXMLWorkbook)
                Call wb3.Close(False)
                End If
 
 
                If InStr(myString, ".3") > 0 Then
                ws.Copy
                Set wb4 = ActiveWorkbook
                sPath4 = sPath1 & Application.PathSeparator & ws.Name
 
                On Error Resume Next
                Kill sPath4 & ".xlsx"
                On Error GoTo 0
 
                Call wb4.SaveAs(sPath4, xlOpenXMLWorkbook)
                Call wb4.Close(False)
                End If
 
                If InStr(myString, ".4") > 0 Then
                ws.Copy
                Set wb5 = ActiveWorkbook
                sPath5 = sPath1 & Application.PathSeparator & ws.Name
 
                On Error Resume Next
                Kill sPath5 & ".xlsx"
                On Error GoTo 0
 
                Call wb5.SaveAs(sPath5, xlOpenXMLWorkbook)
                Call wb5.Close(False)
                End If
 
   End If
   Next
 
 
   wb1.Activate
   Application.ScreenUpdating = False
 
 End Sub

 

[drul]

Salut,
Quel est ta question exactement ?

 

[djedkare]

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

 

[drul]

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)

Option Explicit
Sub SplitSheets()
    Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook, wb4 As Workbook, wb5 As Workbook
    Dim ws As Worksheet
    Dim myString As String
    Dim sPath1 As String, sPath2 As String, sPath3 As String, sPath4 As String, sPath5 As String
    
    Set wb1 = ThisWorkbook
    sPath1 = wb1.Path
    
    Application.ScreenUpdating = False
 
     
    For Each ws In wb1.Worksheets
        If ws.Visible Then
                
                myString = ws.Name
                If InStr(myString, ".1") > 0 Then
                    If wb2 Is Nothing Then
                       ws.Copy
                       Set wb2 = ActiveWorkbook
                       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é ?
                    Else
                        ws.Copy after:=wb2.Sheets(wb2.Sheets.Count)
                    End If
                    
                End If
 
 
       End If
    Next
    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)
    Kill sPath2
    On Error GoTo 0
    Call wb2.SaveAs(sPath2, xlOpenXMLWorkbook)
    Call wb2.Close(False)
 
    wb1.Activate
    Application.ScreenUpdating = true
 End Sub

 

[djedkare]

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)

Option Explicit
Sub SplitSheets()
    Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook, wb4 As Workbook, wb5 As Workbook
    Dim ws As Worksheet
    Dim myString As String
    Dim sPath1 As String, sPath2 As String, sPath3 As String, sPath4 As String, sPath5 As String
    
    Set wb1 = ThisWorkbook
    sPath1 = wb1.Path
    
    Application.ScreenUpdating = False
 
     
    For Each ws In wb1.Worksheets
        If ws.Visible Then
                
                myString = ws.Name
                If InStr(myString, ".1") > 0 Then
                    If wb2 Is Nothing Then
                       ws.Copy
                       Set wb2 = ActiveWorkbook
                       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é ?
                    Else
                        ws.Copy after:=wb2.Sheets(wb2.Sheets.Count)
                    End If
                    
                End If
 
 
       End If
    Next
    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)
    Kill sPath2
    On Error GoTo 0
    Call wb2.SaveAs(sPath2, xlOpenXMLWorkbook)
    Call wb2.Close(False)
 
    wb1.Activate
    Application.ScreenUpdating = true
 End Sub

Merci beaucoup
J'ai juste un dernier petit souci

Option Explicit
Sub SplitSheets()
    Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook, wb4 As Workbook, wb5 As Workbook
    Dim ws As Worksheet
    Dim myString As String
    Dim sPath1 As String, sPath2 As String, sPath3 As String, sPath4 As String, sPath5 As String
 
    Set wb1 = ThisWorkbook
    sPath1 = wb1.Path
 
    Application.ScreenUpdating = False
 
 
    For Each ws In wb1.Worksheets
        If ws.Visible Then
 
                myString = ws.Name
                If InStr(myString, ".1") > 0 Then
                    If wb2 Is Nothing Then
                       ws.Copy
                       Set wb2 = ActiveWorkbook
                       sPath2 = sPath1 & Application.PathSeparator & ws.Name & ".xlsx" 
                    Else
                        ws.Copy after:=wb2.Sheets(wb2.Sheets.Count)
                    End If
 
                End If
 
 
       End If
    Next
    On Error Resume Next 
    Kill sPath2
    On Error GoTo 0
    Call wb2.SaveAs(sPath2, xlOpenXMLWorkbook)
    Call wb2.Close(False)
    
    For Each ws In wb2.Worksheets
        If ws.Visible Then
 
                myString = ws.Name
                If InStr(myString, ".2") > 0 Then
                    If wb3 Is Nothing Then
                       ws.Copy
                       Set wb3 = ActiveWorkbook
                       sPath3 = sPath2 & Application.PathSeparator & ws.Name & ".xlsx"
                    Else
                        ws.Copy after:=wb3.Sheets(wb3.Sheets.Count)
                    End If
 
                End If
 
 
       End If
    Next
    On Error Resume Next
    Kill sPath3
    On Error GoTo 0
    Call wb3.SaveAs(sPath3, xlOpenXMLWorkbook)
    Call wb3.Close(False)
 
    wb1.Activate
    Application.ScreenUpdating = True
 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 ?

 

[drul]

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

Sub SplitSheets()
    Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook, wb4 As Workbook, wb5 As Workbook
    Dim ws As Worksheet
    Dim myString As String
    Dim sPath1 As String, sPath2 As String, sPath3 As String, sPath4 As String, sPath5 As String
 
    Set wb1 = ThisWorkbook
    sPath1 = wb1.Path
 
    Application.ScreenUpdating = False
 
 
    For Each ws In wb1.Worksheets
        If ws.Visible Then
 
                myString = ws.Name
                If InStr(myString, ".1") > 0 Then
                    If wb2 Is Nothing Then
                       ws.Copy
                       Set wb2 = ActiveWorkbook
                       sPath2 = sPath1 & Application.PathSeparator & ws.Name & ".xlsx"
                    Else
                        ws.Copy after:=wb2.Sheets(wb2.Sheets.Count)
                    End If
 
                ElseIf InStr(myString, ".2") > 0 Then
                    If wb3 Is Nothing Then
                       ws.Copy
                       Set wb3 = ActiveWorkbook
                       sPath3 = sPath2 & Application.PathSeparator & ws.Name & ".xlsx"
                    Else
                        ws.Copy after:=wb3.Sheets(wb3.Sheets.Count)
                    End If
 
                End If
 
       End If
    Next
    On Error Resume Next
    Kill sPath2
    Kill sPath3
    On Error GoTo 0
    
    Call wb2.SaveAs(sPath2, xlOpenXMLWorkbook)
    Call wb2.Close(False)
    
    Call wb3.SaveAs(sPath3, xlOpenXMLWorkbook)
    Call wb3.Close(False)

    wb1.Activate
    Application.ScreenUpdating = True
 End Sub

 

[djedkare]

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

Sub SplitSheets()
    Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook, wb4 As Workbook, wb5 As Workbook
    Dim ws As Worksheet
    Dim myString As String
    Dim sPath1 As String, sPath2 As String, sPath3 As String, sPath4 As String, sPath5 As String
 
    Set wb1 = ThisWorkbook
    sPath1 = wb1.Path
 
    Application.ScreenUpdating = False
 
 
    For Each ws In wb1.Worksheets
        If ws.Visible Then
 
                myString = ws.Name
                If InStr(myString, ".1") > 0 Then
                    If wb2 Is Nothing Then
                       ws.Copy
                       Set wb2 = ActiveWorkbook
                       sPath2 = sPath1 & Application.PathSeparator & ws.Name & ".xlsx"
                    Else
                        ws.Copy after:=wb2.Sheets(wb2.Sheets.Count)
                    End If
 
                ElseIf InStr(myString, ".2") > 0 Then
                    If wb3 Is Nothing Then
                       ws.Copy
                       Set wb3 = ActiveWorkbook
                       sPath3 = sPath2 & Application.PathSeparator & ws.Name & ".xlsx"
                    Else
                        ws.Copy after:=wb3.Sheets(wb3.Sheets.Count)
                    End If
 
                End If
 
       End If
    Next
    On Error Resume Next
    Kill sPath2
    Kill sPath3
    On Error GoTo 0
    
    Call wb2.SaveAs(sPath2, xlOpenXMLWorkbook)
    Call wb2.Close(False)
    
    Call wb3.SaveAs(sPath3, xlOpenXMLWorkbook)
    Call wb3.Close(False)

    wb1.Activate
    Application.ScreenUpdating = True
 End Sub

Ahhh mais oui bien sur
merci bcp pour ton aide

 

[drul]

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:

Sub SplitSheets()
    Dim wb(5) As Workbook
    Dim ws As Worksheet
    Dim myString As String
    Dim sPath(5) As String
    Dim i As Integer
    Set wb(0) = ThisWorkbook
    sPath(0) = wb(0).Path
 
    Application.ScreenUpdating = False
 
 
    For Each ws In wb(0).Worksheets
        If ws.Visible Then
            myString = ws.Name 
            For i = 1 To 4
               
                If InStr(myString, "." & i) > 0 Then
                    If wb(i) Is Nothing Then
                       ws.Copy
                       Set wb(i) = ActiveWorkbook
                       sPath(i) = sPath(0) & Application.PathSeparator & ws.Name & ".xlsx"
                    Else
                        ws.Copy after:=wb(i).Sheets(wb(i).Sheets.Count)
                    End If
 
                End If
            Next
       End If
    Next
    For i = 1 To 4
        If sPath(i) <> "" Then
            On Error Resume Next
            Kill sPath(i)
            On Error GoTo 0
            
            Call wb(i).SaveAs(sPath(i), xlOpenXMLWorkbook)
            Call wb(i).Close(False)
        End If
    Next

    wb(0).Activate
    Application.ScreenUpdating = True
 End Sub

 

[djedkare]

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:

Sub SplitSheets()
    Dim wb(5) As Workbook
    Dim ws As Worksheet
    Dim myString As String
    Dim sPath(5) As String
    Dim i As Integer
    Set wb(0) = ThisWorkbook
    sPath(0) = wb(0).Path
 
    Application.ScreenUpdating = False
 
 
    For Each ws In wb(0).Worksheets
        If ws.Visible Then
            myString = ws.Name 
            For i = 1 To 4
               
                If InStr(myString, "." & i) > 0 Then
                    If wb(i) Is Nothing Then
                       ws.Copy
                       Set wb(i) = ActiveWorkbook
                       sPath(i) = sPath(0) & Application.PathSeparator & ws.Name & ".xlsx"
                    Else
                        ws.Copy after:=wb(i).Sheets(wb(i).Sheets.Count)
                    End If
 
                End If
            Next
       End If
    Next
    For i = 1 To 4
        If sPath(i) <> "" Then
            On Error Resume Next
            Kill sPath(i)
            On Error GoTo 0
            
            Call wb(i).SaveAs(sPath(i), xlOpenXMLWorkbook)
            Call wb(i).Close(False)
        End If
    Next

    wb(0).Activate
    Application.ScreenUpdating = True
 End Sub

Super c'est ce qu'il me fallait !!
merci !!

 

[drul]

si tu es satisfait, alors clos le sujet stp