Eclater en plusieurs fichiers et onglet

Bonjour,

Je débute en macro, malgré mes recherches sur le forum je ne trouve pas de solution. Je souhaite dans un premier temps éclater un fichier en plusieurs classeurs et ensuite démultiplier en onglet (2e variable). J'ai fais ceci :

Pour l'instant cela fonctionne quand j'éclate une première fois en un classeur et en onglet mais quand je veux éclater en un deuxième classeur la boucle pour démultiplier les onglets n'est plus détectée...

Je ne sais pas si j'ai bien expliqué, ci-joint mon fichier test ainsi que la macro.

Merci beaucoup pour votre aide !

Sub Eclatement_3()

Dim classeur As String

Dim repartition As String

classeur = Cells(2, 8)

repartition = Cells(2, 7)

Do While classeur <> ""

Range("A1").Select

ActiveSheet.Range("$A$1:$Z$1500").AutoFilter Field:=8, Criteria1:=classeur

Selection.CurrentRegion.Select

Selection.Copy

Workbooks.Add

ActiveSheet.Paste

Do While repartition <> ""

Sheets("Feuil1").Select

Range("A1").Select

ActiveSheet.Range("$A$1:$Z$1500").AutoFilter Field:=7, Criteria1:=repartition

Selection.CurrentRegion.Select

Selection.Copy

Sheets.Add After:=Sheets(Sheets.Count)

ActiveSheet.Paste

Sheets("Feuil1").Select

Range("A2").Select

Range(Selection, Selection.End(xlDown)).Select

Selection.EntireRow.Delete

repartition = Cells(2, 7)

Loop

Sheets("Feuil1").Select

ActiveWindow.SelectedSheets.Delete

Windows("TEST.xlsm").Activate

Range("A2").Select

Range(Selection, Selection.End(xlDown)).Select

Selection.EntireRow.Delete

classeur = Cells(2, 8).Value

Loop

End Sub

Bonjour et bienvenue sur le forum

Tu devrais expliquer précisément ce que tu veux obtenir avec les données indiquées dans les colonnes des différents onglets du classeur que tu as joint.

A te relire.

Bye !

Bonjour,

J'ai une base de données et je voudrais éclater en copiant les données en fonction des données dans la colonne classeur cad :

1 fichier commerce avec un feuillet Paris et les données et un 2e feuillet avec les données de Marseille

1 fichier tete de groupe avec un feuillet Lyon et 2e feuillet Toulouse

Merci !

Bonjour Ippo, gmb

Vois ceci :

Option Explicit
Sub test()
    Dim i As Long, dico As Object, e, s, t As Long
    Set dico = CreateObject("Scripting.dictionary")
    dico.CompareMode = 1
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    With Sheets("CS").Cells(1).CurrentRegion
        For i = 2 To .Rows.Count
            If Not dico.exists(.Cells(i, 8).Value) Then
                Set dico(.Cells(i, 8).Value) = _
                CreateObject("Scripting.dictionary")
                dico(.Cells(i, 8).Value).CompareMode = 1
            End If
            If Not dico(.Cells(i, 8).Value).exists(.Cells(i, 7).Value) Then
                Set dico(.Cells(i, 8).Value)(.Cells(i, 7).Value) = .Rows(1)
            End If
            Set dico(.Cells(i, 8).Value)(.Cells(i, 7).Value) = _
            Union(dico(.Cells(i, 8).Value)(.Cells(i, 7).Value), .Rows(i))
        Next
    End With
    For Each e In dico
        t = 0
        With Workbooks.Add
            For Each s In dico(e)
                t = t + 1
                If t > .Sheets.Count Then
                    Sheets.Add after:=.Sheets(.Sheets.Count)
                End If
                With .Sheets(t)
                    dico(e)(s).Copy .Cells(1)
                    .Name = s
                End With
            Next
            '.SaveAs ThisWorkbook.Path & "\" & e & ".xls"
            .SaveAs ThisWorkbook.Path & "\" & e & ".xlsx"
            .Close False
        End With
    Next
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

klin89

Un essai à tester. Te convient-il ?

Bye !

Bonjour Gmb, Klin89

désolée pour ma réponse tardive ! merci à vous deux les deux propositions répondent pleinement à mon besoin. Je regarde laquelle des deux est "à ma portée" et qui pourrait être "maintenue". J'ai l'impression que la solution de Gmb ressemble à la mienne. Je gagne 3h d'éclatement sans risque d'erreur... En tout cas un grand merci. Bonne journée