Créer une macro pour scinder un fichier global en sous-fichiers

Bonjour à tous,

J'espère que vous vous portez bien.

Je sollicite votre aide pour créer une macro automatique pour découper un fichier global (données d'une région) mis en pièce-jointe en sous-fichiers (par ville de la région).

Lien de téléchargement du fichier global : https://drive.google.com/file/d/1gGaXoN99ReUt3zmf3ZZ2RYEoiYacmSYn/view?usp=sharing

L'idée est d'exécuter la macro sur ce fichier global est d'avoir le nombre souhaité variable de sous-fichiers (dans cet exemple, on a 20 : lignes de ARGENTON à VIERZON) avec la même structure que le fichier global :

- Premier onglet : tableau croisé dynamique --> avoir qu'une ligne (Exemple : ARGENTON) (1ère photo)

- Deuxième onglet : Data --> Filtrer la colonne C (avec le nom de la ville : ARGENTON par ex) (2ème photo)

Merci d'avance pour votre aide,

Bonjour,

je ne peux pas y accéder "Une autorisation est nécessaire"

Ah bon, tu n'as pas pu accéder au fichier ?

J'ai minimisé le fichier en gardant le nécessaire. Il est en PJ.

Merci,

Ton TCD ne correspond pas aux données de data ! tu as supprimé des colonnes sans actualiser le TCD.

Ajoute cette macro à ton fichier

Option Explicit
Public critere%

Sub dispatcher()
Dim Tbl As Variant, data As Variant, i%
Dim dico1 As Object, cle1 As Variant, result1 As Variant
Dim wb As Excel.Workbook
Dim MonRepertoire, Repertoire As FileDialog, racine As String

    critere = 3 ' colonne C

    racine = Split(ThisWorkbook.Name, ".")(0)

    Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
    Application.FileDialog(msoFileDialogFolderPicker).Title = "Choix du répertoire de stockage des fichiers générés"
    Repertoire.Show
    If Repertoire.SelectedItems.Count = 0 Then Exit Sub
    MonRepertoire = Repertoire.SelectedItems(1)

    data = Sheets("data").Cells(Rows.Count, 1).End(xlUp).CurrentRegion

    Set dico1 = CreateObject("Scripting.Dictionary")
    For i = LBound(data) + 1 To UBound(data) ' hors en-tête
        dico1(data(i, critere)) = ""
    Next

    Application.ScreenUpdating = False
    For Each cle1 In dico1.Keys
        result1 = filtreArray(data, critere, cle1)
        Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & "Model.xlsx")
        wb.Sheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(UBound(result1, 1), UBound(result1, 2)) = result1
        wb.Sheets(1).PivotTables(1).PivotCache.Refresh
        wb.SaveAs (MonRepertoire & "\" & racine & "_" & cle1 & ".xlsx")
        wb.Close
        Set wb = Nothing
    Next
    Application.ScreenUpdating = True

    MsgBox "Terminé, fichiers sauvegardés sous """ & MonRepertoire & "\" & """ !"
End Sub

Function filtreArray(Tbl, col, param)
Dim i%, j%, k%, n%
    For i = 1 To UBound(Tbl)
        If Tbl(i, col) = param Then n = n + 1
    Next i
    Dim temp: ReDim temp(1 To n, 1 To UBound(Tbl, 2))

    j = 0
    For i = 1 To UBound(Tbl)
        If Tbl(i, col) = param Then
            j = j + 1
            For k = 1 To UBound(Tbl, 2)
                temp(j, k) = Tbl(i, k)
            Next k
        End If
    Next i
    filtreArray = temp
End Function

et ajoute ce fichier à côté du fichier à dispatcher

Excuse-moi, je voulais minimiser les données pour toi. Voilà maintenant, l'onglet data avec son TCD. Je teste ta macro du coup sur ce fichier ??

J'ai testé. ça fonctionne très bien pour l'onglet data je pense. Pour le TCD, la macro filtre bien mais pas avec les BONS chiffres comme le fichier source.

Y a-t-il un moyen d'enlever le mot macro dans les noms des fichiers générés ?

Et pour le fichier MODEL, c'est obligatoire ? Y a pas un moyen d'avoir que la macro sans ce fichier ? Je sais que c'est un template. Mais si c'est possible d'avoir que la macro à exécuter, ça sera top.

Merci beaucoup, je te laisse tester de ton côté.

Non le modèle est indispensable ici !

Si les stats ne sont pas bonnes, merci de me donner un exemple.

ça marche parfaitement. Je t'ai posé la question pour le Model, parce que je crains qu'il soit perdu entre les utilisateurs. Tu n'as pas une autre alternative ? Genre, l'insérer dans le fichier, code vba ou peu importe..

Peux-tu renommer les fichiers générés sous forme : REORG_XXXXXX_YYYYY ?

Merci bcp !

Pour le modèle, je n'ai pas d'autre alternative simple.

Pour le nom du fichier, change

wb.SaveAs (MonRepertoire & "\" & cle1 & ".xlsx")

en

wb.SaveAs (MonRepertoire & "\REORG_" & cle1 & ".xlsx")

la cle1 c'est ce que tu mets dans ton fichier colonne C, je ne vais pas le changer !

Bonsoir,

Est-ce que tu peux me renvoyer le fichier Model adapté à ce nouveau fichier de base (en PJ) ? J'ai rajouté quelques onglets. Merci beaucoup,

J'ai essayé de l'adapter, mais ça me donne un message d'erreur.

J'ai une erreur sur ton fichier

C'est très bizarre, regarde sur ce fichier. Moi je ne l'ai pas

Si tu as tjrs ce message d'erreur, change la source des données (rubrique Analyse) et sélectionne toutes les données de l'onglet data

Tu peux me laisser ton aide mail ? Je te l'enverrai au complet si tu veux (avec tous les onglets que je souhaite avoir).

Pas de mail perso. Si besoin mp.

Le message d'erreur est toujours là car tu as supprimé les en-têtes de colonnes BL1 à FZ1

Macro adaptée (pas testée)

Option Explicit
Public critere%

Sub dispatcher()
Dim Tbl As Variant, data As Variant, i%
Dim dico1 As Object, cle1 As Variant, result1 As Variant
Dim wb As Excel.Workbook
Dim MonRepertoire, Repertoire As FileDialog, racine As String

    critere = 3 ' colonne C

    racine = Split(ThisWorkbook.Name, ".")(0)

    Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
    Application.FileDialog(msoFileDialogFolderPicker).Title = "Choix du répertoire de stockage des fichiers générés"
    Repertoire.Show
    If Repertoire.SelectedItems.Count = 0 Then Exit Sub
    MonRepertoire = Repertoire.SelectedItems(1)

    data = Sheets("data").Cells(Rows.Count, 1).End(xlUp).CurrentRegion

    Set dico1 = CreateObject("Scripting.Dictionary")
    For i = LBound(data) + 1 To UBound(data) ' hors en-tête
        dico1(data(i, critere)) = ""
    Next

    Application.ScreenUpdating = False
    For Each cle1 In dico1.Keys
        result1 = filtreArray(data, critere, cle1)
        Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & "Model.xlsx")
        wb.Sheets(4).Cells(2, 1).Resize(UBound(result1, 1), UBound(result1, 2)) = result1
        wb.Sheets(1).PivotTables(1).ChangePivotCache wb.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="data!R1C1:R" & (UBound(result1, 1) + 1) & "C180", Version:=xlPivotTableVersion15)
        wb.Sheets(1).PivotTables(1).PivotCache.Refresh
        wb.Sheets(2).PivotTables(1).ChangePivotCache wb.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="data!R1C1:R" & (UBound(result1, 1) + 1) & "C180", Version:=xlPivotTableVersion15)
        wb.Sheets(2).PivotTables(1).PivotCache.Refresh
        wb.Sheets(3).PivotTables(1).ChangePivotCache wb.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="data!R1C1:R" & (UBound(result1, 1) + 1) & "C180", Version:=xlPivotTableVersion15)
        wb.Sheets(3).PivotTables(1).PivotCache.Refresh
        wb.SaveAs (MonRepertoire & "\" & cle1 & ".xlsx")
        wb.Close
        Set wb = Nothing
    Next
    Application.ScreenUpdating = True

    MsgBox "Terminé, fichiers sauvegardés sous """ & MonRepertoire & "\" & """ !"
End Sub

Function filtreArray(Tbl, col, param)
Dim i%, j%, k%, n%
    For i = 1 To UBound(Tbl)
        If Tbl(i, col) = param Then n = n + 1
    Next i
    Dim temp: ReDim temp(1 To n, 1 To UBound(Tbl, 2))

    j = 0
    For i = 1 To UBound(Tbl)
        If Tbl(i, col) = param Then
            j = j + 1
            For k = 1 To UBound(Tbl, 2)
                temp(j, k) = Tbl(i, k)
            Next k
        End If
    Next i
    filtreArray = temp
End Function

et nouveau modèle

Merci beaucoup Steelson (tu es mon héro ;) ). Je mets le sujet comme résolu.

Si j'ai d'autres questions, je reviens vers toi si ça ne te dérange pas.

Bonne soirée,