Microsoft 365 Scinder des données en plusieurs fichiers Excel avec nom généré automatiquement

jckbrtn à dit:

Bonjour à tous,

Je cherche à scinder des données Excel dans différents fichiers Excel avec comme un nom de fichier généré via les infos de 2 colonnes.

Un exemple en annexe : les données brutes et dans les feuilles de calcul, les données qui devraient être scindées dans des fichiers différents avec le nom de fichier désiré colonne A et B = 161 AAAA par exemple

Merci d’avance pour votre aide !

Cliquez pour agrandir...

Sub Creation()
    Dim Plage, C As Range
    Application.ScreenUpdating = False
    With Feuil1
        Set Plage = .[a1].CurrentRegion
        On Error Resume Next    ' si rien à filtrer
        Plage.Resize(, Plage.Columns.Count - 4).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("I1:J1"), Unique:=True
        For Each C In .Range("i2:i" & Application.Count(.Columns(9)))
            If Not Evaluate("ISREF('" & C & " " & C.Offset(, 1) & "'!A1)") Then Sheets.Add.Name = C & " " & C.Offset(, 1)
            With Sheets(C & " " & C.Offset(, 1))
                .Columns("a:f").Clear
                Plage.AutoFilter Field:=1, Criteria1:=C
                Plage.SpecialCells(xlCellTypeVisible).Copy .[a1]
            End With
        Next
        Plage.AutoFilter: .Columns("i:j").Clear: .[a1].Activate
    End With
End Sub

Jacky67 à dit:

Bonjour à tous
Une proposition toutes versions xl en PJ par vba avec ce code

VB:

Sub Creation()
    Dim Plage, C As Range
    Application.ScreenUpdating = False
    With Feuil1
        Set Plage = .[a1].CurrentRegion
        On Error Resume Next    ' si rien à filtrer
        Plage.Resize(, Plage.Columns.Count - 4).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("I1:J1"), Unique:=True
        For Each C In .Range("i2:i" & Application.Count(.Columns(9)))
            If Not Evaluate("ISREF('" & C & " " & C.Offset(, 1) & "'!A1)") Then Sheets.Add.Name = C & " " & C.Offset(, 1)
            With Sheets(C & " " & C.Offset(, 1))
                .Columns("a:f").Clear
                Plage.AutoFilter Field:=1, Criteria1:=C
                Plage.SpecialCells(xlCellTypeVisible).Copy .[a1]
            End With
        Next
        Plage.AutoFilter: .Columns("i:j").Clear: .[a1].Activate
    End With
End Sub

Oupps, s'il faut créer des classeurs et non des feuilles, une version V2
Les classeurs sont créés dans le répertoire du classeur maitre

Cliquez pour agrandir...

Jacky67 à dit:

Bonjour à tous
Une proposition toutes versions xl en PJ par vba avec ce code

VB:

Sub Creation()
    Dim Plage, C As Range
    Application.ScreenUpdating = False
    With Feuil1
        Set Plage = .[a1].CurrentRegion
        On Error Resume Next    ' si rien à filtrer
        Plage.Resize(, Plage.Columns.Count - 4).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("I1:J1"), Unique:=True
        For Each C In .Range("i2:i" & Application.Count(.Columns(9)))
            If Not Evaluate("ISREF('" & C & " " & C.Offset(, 1) & "'!A1)") Then Sheets.Add.Name = C & " " & C.Offset(, 1)
            With Sheets(C & " " & C.Offset(, 1))
                .Columns("a:f").Clear
                Plage.AutoFilter Field:=1, Criteria1:=C
                Plage.SpecialCells(xlCellTypeVisible).Copy .[a1]
            End With
        Next
        Plage.AutoFilter: .Columns("i:j").Clear: .[a1].Activate
    End With
End Sub

Oupps, s'il faut créer des classeurs et non des feuilles, une version V2
Les classeurs sont créés dans le répertoire du classeur maitre

Cliquez pour agrandir...

Jacky67 à dit:

Bonjour à tous
Une proposition toutes versions xl en PJ par vba avec ce code

VB:

Sub Creation()
    Dim Plage, C As Range
    Application.ScreenUpdating = False
    With Feuil1
        Set Plage = .[a1].CurrentRegion
        On Error Resume Next    ' si rien à filtrer
        Plage.Resize(, Plage.Columns.Count - 4).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("I1:J1"), Unique:=True
        For Each C In .Range("i2:i" & Application.Count(.Columns(9)))
            If Not Evaluate("ISREF('" & C & " " & C.Offset(, 1) & "'!A1)") Then Sheets.Add.Name = C & " " & C.Offset(, 1)
            With Sheets(C & " " & C.Offset(, 1))
                .Columns("a:f").Clear
                Plage.AutoFilter Field:=1, Criteria1:=C
                Plage.SpecialCells(xlCellTypeVisible).Copy .[a1]
            End With
        Next
        Plage.AutoFilter: .Columns("i:j").Clear: .[a1].Activate
    End With
End Sub

Oupps, s'il faut créer des classeurs et non des feuilles, une version V2
Les classeurs sont créés dans le répertoire du classeur maitre

Cliquez pour agrandir...

Plage.Resize(, Plage.Columns.Count - 4).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("I1:J1"), Unique:=True
.Columns("a:f").Clear

jckbrtn à dit:

Bonsoir Jacky,

J'avais testé et réussi à modifier ta macro car j'avais ajouter une colonne à mon tableau initial (en annexe).
J'avais noté d'adapter les lignes suivantes à ta macro mais je n'y arrive plus...

VB:

Plage.Resize(, Plage.Columns.Count - 4).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("I1:J1"), Unique:=True
.Columns("a:f").Clear

Est-ce que tu pourrais m'aider, stp?

Merci d'avance et bon week end,

Jckbrtn

Cliquez pour agrandir...

Sub Creation()
    Dim Plage, C As Range
    Application.ScreenUpdating = False
    With Feuil1
        Set Plage = .[a1].CurrentRegion
        On Error Resume Next    ' si rien à filtrer
        Plage.Resize(, Plage.Columns.Count - 5).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("I1:J1"), Unique:=True
        For Each C In .Range("i2:i" & Application.CountA(.Columns(9)))
            If Not Evaluate("ISREF('" & C & " " & C.Offset(, 1) & "'!A1)") Then Sheets.Add.Name = C & " " & C.Offset(, 1)
            With Sheets(C & " " & C.Offset(, 1))
                .Columns("a:g").Clear
                Plage.AutoFilter Field:=1, Criteria1:=C
                Plage.SpecialCells(xlCellTypeVisible).Copy .[a1]
            End With
        Next
        Plage.AutoFilter: .Columns("i:j").Clear: .Activate
    End With
End Sub

Jacky67 à dit:

Re..
On reste donc à la création de feuilles.
Les données numérique de la colonne A sont devenues des données texte
Donc ....Application.Count(.Columns(9))) devient Application.CountA(.Columns(9)))

VB:

Sub Creation()
    Dim Plage, C As Range
    Application.ScreenUpdating = False
    With Feuil1
        Set Plage = .[a1].CurrentRegion
        On Error Resume Next    ' si rien à filtrer
        Plage.Resize(, Plage.Columns.Count - 5).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("I1:J1"), Unique:=True
        For Each C In .Range("i2:i" & Application.CountA(.Columns(9)))
            If Not Evaluate("ISREF('" & C & " " & C.Offset(, 1) & "'!A1)") Then Sheets.Add.Name = C & " " & C.Offset(, 1)
            With Sheets(C & " " & C.Offset(, 1))
                .Columns("a:g").Clear
                Plage.AutoFilter Field:=1, Criteria1:=C
                Plage.SpecialCells(xlCellTypeVisible).Copy .[a1]
            End With
        Next
        Plage.AutoFilter: .Columns("i:j").Clear: .Activate
    End With
End Sub

Cliquez pour agrandir...

 If Not Evaluate("ISREF('" & C & " " & C.Offset(, 1) & "'!A1)") Then Sheets.Add.Name = C & " " & C.Offset(, 1)

            With Sheets(C & " " & C.Offset(, 1))

jckbrtn à dit:

Salut Jacky,

Merci de t'être penché rapidement sur mon problème.
Ca fonctionne sauf que ça créée des feuilles séparés et pas des fichiers.
Il faut modifier un truc dans ...?

Code:

 If Not Evaluate("ISREF('" & C & " " & C.Offset(, 1) & "'!A1)") Then Sheets.Add.Name = C & " " & C.Offset(, 1)

            With Sheets(C & " " & C.Offset(, 1))

Merci pour ton énième aide,

Jckbrtn

Cliquez pour agrandir...

Jacky67 à dit:

Re..
Ben...oui ; c'est celui que tu as fourni en PJ #7
J'avais constaté et précisé
On reste donc à la création de feuilles.
Même modif sur celui qui crée des classeurs

Cliquez pour agrandir...