Scinder un fichier Excel en plusieurs fichier

Le 26/04/2017 à 19:20

Bonjour à tous,

J'ai un fichier comportant de 1077 lignes que je veux scinder en plusieurs autres.

Il s'agit d'un fichier qui regroupe plusieurs informations qui concernent des AGENCE.

Pouvez-vous m'aider à faire un script pour avoir un fichier par AGENCE avec les données qui le concerne uniquement.

Et que chaque fichier porte le nom de chaque agence.

Merci à vous pour votre aide.

30fichier-point-de-vente.xlsx (71.75 Ko)

31fichier-point-de-vente.xlsx (71.75 Ko)

Le 26/04/2017 à 21:30

Bonsoir Tizahh, bonsoir le forum,

En pièce jointe ton fichier modifié avec le code ci-dessous :

Sub Macro1()
Dim CS As Workbook 'définit la variable CS (Classeur Source)
Dim OS As Worksheet 'définit la variable OS (Onglet Source)
Dim CA As String 'définit la variable CA (Chemin d'Accès)
Dim TV As Variant 'définit la variable TV (Tableau des Valeurs)
Dim D As Object 'définit la variable D (Dictionnaire)
Dim I As Long 'définit la variable I (Incrément)
Dim TMP As Variant 'définit la variable TMP (tableau TeMPoraire)
Dim K As Long 'définit la variable K (incrément)
Dim TL() As Variant 'définit la variable TL (Tableau des Lignes)
Dim NO As Byte 'décare la variable NO (Nombre d'Onglets)
Dim CD As Workbook 'définit la variable CD (Classeur Destination)
Dim OD As Worksheet 'définit la variable OD (Onglet Destination)

MsgBox "L'exécution du processus peut prendre un certain temps. Un message vous avertira de la fin du traitement des données." 'message de début
Application.ScreenUpdating = False 'masque les rafraîchissement d'écran
NO = Application.SheetsInNewWorkbook 'récupère dans la variable NO le nombre initial d'onglet par défaut d'un nouveau classeur
Set CS = ThisWorkbook 'définit le classeur source CS
Set OS = CS.Worksheets("Feuil1") 'définit l'onglet source OS
CA = CS.Path & "\" 'définit le chemin d'accès CA
TV = OS.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    D(TV(I, 1)) = "" 'alimente le dictionnaire D avec les données de la première colonne du tableau des valeurs TV
Next I 'prochaine ligne de la boucle
TMP = D.keys 'récupère dans le tableau temporaire TMP la liste des éléments du dictionnaire D sans doublon
For J = 0 To UBound(TMP) 'boucle 1 : sur tous les éléments J du tableau temporaire TMP
    K = 1: Erase TL: Set CD = Nothing: Set OD = Nothing 'réinitialise K, vide TL, CD et OD de la mémoire
    For I = 2 To UBound(TV, 1) 'boucle 2 : sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
        If TV(I, 1) = TMP(J) Then 'condition : si la donnée ligne I colonne 1 de TV est égale à la valeur de TMP(J)
            ReDim Preserve TL(1 To 3, 1 To K) 'redimensionne le tableau des lignes TL (3 lignes, K colonnes)
            For L = 1 To 3 'boucle 3 : sur toutes les colonnes L du tableau des valeurs TV
                TL(L, K) = TV(I, L) 'récupère dans la ligne L de TL la donnée en colonne L de TV (= Transposition)
            Next L 'prochaine colonne de la boucle 3
            K = K + 1 'incrémente K (ajoute une colonne au tableau des lignes TL)
        End If 'fin de la condition
    Next I 'prochaine ligne de la boucle 2
    If K > 1 Then 'condition : si K est supérieure à 1
        Application.SheetsInNewWorkbook = 1 'définit le nombre d'onglet d'un nouveau classeur par défaut égale à 1
        Application.Workbooks.Add (xlWBATWorksheet) 'ajoute un nouveau classeur
        Set CD = ActiveWorkbook 'définit le classeur destination CD
        Set OD = CD.Worksheets(1) 'définit l'onglet destination OD
        OS.Range("A1:C1").Copy 'copie la plage A1:C1 de l'onglet source
        OD.Range("A1").PasteSpecial (xlPasteColumnWidths) 'colle dans A1 de l'onglet destination la largeur des colonnes
        OS.Range("A1:C1").Copy 'copie la plage A1:C1 de l'onglet source
        OD.Range("A1").PasteSpecial (xlPasteAllUsingSourceTheme) 'colle dans A1 de l'onglet destination les valeurs et les formats
        'renvoie dans la cellule A2 redimensionnée le tableau TL transposé
        OD.Range("A2").Resize(UBound(TL, 2), UBound(TL, 1)).Value = Application.Transpose(TL)
        CD.SaveAs (CA & TMP(J) & ".xlsx") 'enregistre-sous le classeur destination CD
        CD.Close False 'ferme le classeur destination CD sans enregistrer les changements
    End If 'fin de la condition
Next J 'prochain élément de la boucxle 1
Application.ScreenUpdating = True 'affiche les rafraîchissement d'écran
Application.SheetsInNewWorkbook = NO 'redéfinit le nombre d'onglet par défaut initial
MsgBox "Le fichier a été scindé en " & D.Count & " fichiers !" 'message de fin
End Sub

Par conséquent, il prend l'extension .xlsm...

61fichier-point-de-vente.xlsm (56.61 Ko)

Le 27/04/2017 à 09:50

ThauThème a écrit :

Bonsoir Tizahh, bonsoir le forum,

En pièce jointe ton fichier modifié avec le code ci-dessous :

Sub Macro1()
Dim CS As Workbook 'définit la variable CS (Classeur Source)
Dim OS As Worksheet 'définit la variable OS (Onglet Source)
Dim CA As String 'définit la variable CA (Chemin d'Accès)
Dim TV As Variant 'définit la variable TV (Tableau des Valeurs)
Dim D As Object 'définit la variable D (Dictionnaire)
Dim I As Long 'définit la variable I (Incrément)
Dim TMP As Variant 'définit la variable TMP (tableau TeMPoraire)
Dim K As Long 'définit la variable K (incrément)
Dim TL() As Variant 'définit la variable TL (Tableau des Lignes)
Dim NO As Byte 'décare la variable NO (Nombre d'Onglets)
Dim CD As Workbook 'définit la variable CD (Classeur Destination)
Dim OD As Worksheet 'définit la variable OD (Onglet Destination)

MsgBox "L'exécution du processus peut prendre un certain temps. Un message vous avertira de la fin du traitement des données." 'message de début
Application.ScreenUpdating = False 'masque les rafraîchissement d'écran
NO = Application.SheetsInNewWorkbook 'récupère dans la variable NO le nombre initial d'onglet par défaut d'un nouveau classeur
Set CS = ThisWorkbook 'définit le classeur source CS
Set OS = CS.Worksheets("Feuil1") 'définit l'onglet source OS
CA = CS.Path & "\" 'définit le chemin d'accès CA
TV = OS.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    D(TV(I, 1)) = "" 'alimente le dictionnaire D avec les données de la première colonne du tableau des valeurs TV
Next I 'prochaine ligne de la boucle
TMP = D.keys 'récupère dans le tableau temporaire TMP la liste des éléments du dictionnaire D sans doublon
For J = 0 To UBound(TMP) 'boucle 1 : sur tous les éléments J du tableau temporaire TMP
    K = 1: Erase TL: Set CD = Nothing: Set OD = Nothing 'réinitialise K, vide TL, CD et OD de la mémoire
    For I = 2 To UBound(TV, 1) 'boucle 2 : sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
        If TV(I, 1) = TMP(J) Then 'condition : si la donnée ligne I colonne 1 de TV est égale à la valeur de TMP(J)
            ReDim Preserve TL(1 To 3, 1 To K) 'redimensionne le tableau des lignes TL (3 lignes, K colonnes)
            For L = 1 To 3 'boucle 3 : sur toutes les colonnes L du tableau des valeurs TV
                TL(L, K) = TV(I, L) 'récupère dans la ligne L de TL la donnée en colonne L de TV (= Transposition)
            Next L 'prochaine colonne de la boucle 3
            K = K + 1 'incrémente K (ajoute une colonne au tableau des lignes TL)
        End If 'fin de la condition
    Next I 'prochaine ligne de la boucle 2
    If K > 1 Then 'condition : si K est supérieure à 1
        Application.SheetsInNewWorkbook = 1 'définit le nombre d'onglet d'un nouveau classeur par défaut égale à 1
        Application.Workbooks.Add (xlWBATWorksheet) 'ajoute un nouveau classeur
        Set CD = ActiveWorkbook 'définit le classeur destination CD
        Set OD = CD.Worksheets(1) 'définit l'onglet destination OD
        OS.Range("A1:C1").Copy 'copie la plage A1:C1 de l'onglet source
        OD.Range("A1").PasteSpecial (xlPasteColumnWidths) 'colle dans A1 de l'onglet destination la largeur des colonnes
        OS.Range("A1:C1").Copy 'copie la plage A1:C1 de l'onglet source
        OD.Range("A1").PasteSpecial (xlPasteAllUsingSourceTheme) 'colle dans A1 de l'onglet destination les valeurs et les formats
        'renvoie dans la cellule A2 redimensionnée le tableau TL transposé
        OD.Range("A2").Resize(UBound(TL, 2), UBound(TL, 1)).Value = Application.Transpose(TL)
        CD.SaveAs (CA & TMP(J) & ".xlsx") 'enregistre-sous le classeur destination CD
        CD.Close False 'ferme le classeur destination CD sans enregistrer les changements
    End If 'fin de la condition
Next J 'prochain élément de la boucxle 1
Application.ScreenUpdating = True 'affiche les rafraîchissement d'écran
Application.SheetsInNewWorkbook = NO 'redéfinit le nombre d'onglet par défaut initial
MsgBox "Le fichier a été scindé en " & D.Count & " fichiers !" 'message de fin
End Sub

Par conséquent, il prend l'extension .xlsm...

Bonjour ThauThème,

Merci pour ta réponse extrèmement rapide, qui répond parfaitement à mon besoin.

J'ai testé et ça marche parfaitement.

Toutefois j'ai une autre question, j'ai le même besoin sur un tableau qui a plus de colonne (9 colonnes contre 3 pour le ficher qui était uploadé).

Qu'elle est la partie du code qu'il faut modifier pour que ces 6 colonnes en plus soient copiées dans les fichiers des agences.

Merci par avance.

Tizahh a écrit :

ThauThème a écrit :

Bonsoir Tizahh, bonsoir le forum,

En pièce jointe ton fichier modifié avec le code ci-dessous :

Sub Macro1()
Dim CS As Workbook 'définit la variable CS (Classeur Source)
Dim OS As Worksheet 'définit la variable OS (Onglet Source)
Dim CA As String 'définit la variable CA (Chemin d'Accès)
Dim TV As Variant 'définit la variable TV (Tableau des Valeurs)
Dim D As Object 'définit la variable D (Dictionnaire)
Dim I As Long 'définit la variable I (Incrément)
Dim TMP As Variant 'définit la variable TMP (tableau TeMPoraire)
Dim K As Long 'définit la variable K (incrément)
Dim TL() As Variant 'définit la variable TL (Tableau des Lignes)
Dim NO As Byte 'décare la variable NO (Nombre d'Onglets)
Dim CD As Workbook 'définit la variable CD (Classeur Destination)
Dim OD As Worksheet 'définit la variable OD (Onglet Destination)

MsgBox "L'exécution du processus peut prendre un certain temps. Un message vous avertira de la fin du traitement des données." 'message de début
Application.ScreenUpdating = False 'masque les rafraîchissement d'écran
NO = Application.SheetsInNewWorkbook 'récupère dans la variable NO le nombre initial d'onglet par défaut d'un nouveau classeur
Set CS = ThisWorkbook 'définit le classeur source CS
Set OS = CS.Worksheets("Feuil1") 'définit l'onglet source OS
CA = CS.Path & "\" 'définit le chemin d'accès CA
TV = OS.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    D(TV(I, 1)) = "" 'alimente le dictionnaire D avec les données de la première colonne du tableau des valeurs TV
Next I 'prochaine ligne de la boucle
TMP = D.keys 'récupère dans le tableau temporaire TMP la liste des éléments du dictionnaire D sans doublon
For J = 0 To UBound(TMP) 'boucle 1 : sur tous les éléments J du tableau temporaire TMP
    K = 1: Erase TL: Set CD = Nothing: Set OD = Nothing 'réinitialise K, vide TL, CD et OD de la mémoire
    For I = 2 To UBound(TV, 1) 'boucle 2 : sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
        If TV(I, 1) = TMP(J) Then 'condition : si la donnée ligne I colonne 1 de TV est égale à la valeur de TMP(J)
            ReDim Preserve TL(1 To 3, 1 To K) 'redimensionne le tableau des lignes TL (3 lignes, K colonnes)
            For L = 1 To 3 'boucle 3 : sur toutes les colonnes L du tableau des valeurs TV
                TL(L, K) = TV(I, L) 'récupère dans la ligne L de TL la donnée en colonne L de TV (= Transposition)
            Next L 'prochaine colonne de la boucle 3
            K = K + 1 'incrémente K (ajoute une colonne au tableau des lignes TL)
        End If 'fin de la condition
    Next I 'prochaine ligne de la boucle 2
    If K > 1 Then 'condition : si K est supérieure à 1
        Application.SheetsInNewWorkbook = 1 'définit le nombre d'onglet d'un nouveau classeur par défaut égale à 1
        Application.Workbooks.Add (xlWBATWorksheet) 'ajoute un nouveau classeur
        Set CD = ActiveWorkbook 'définit le classeur destination CD
        Set OD = CD.Worksheets(1) 'définit l'onglet destination OD
        OS.Range("A1:C1").Copy 'copie la plage A1:C1 de l'onglet source
        OD.Range("A1").PasteSpecial (xlPasteColumnWidths) 'colle dans A1 de l'onglet destination la largeur des colonnes
        OS.Range("A1:C1").Copy 'copie la plage A1:C1 de l'onglet source
        OD.Range("A1").PasteSpecial (xlPasteAllUsingSourceTheme) 'colle dans A1 de l'onglet destination les valeurs et les formats
        'renvoie dans la cellule A2 redimensionnée le tableau TL transposé
        OD.Range("A2").Resize(UBound(TL, 2), UBound(TL, 1)).Value = Application.Transpose(TL)
        CD.SaveAs (CA & TMP(J) & ".xlsx") 'enregistre-sous le classeur destination CD
        CD.Close False 'ferme le classeur destination CD sans enregistrer les changements
    End If 'fin de la condition
Next J 'prochain élément de la boucxle 1
Application.ScreenUpdating = True 'affiche les rafraîchissement d'écran
Application.SheetsInNewWorkbook = NO 'redéfinit le nombre d'onglet par défaut initial
MsgBox "Le fichier a été scindé en " & D.Count & " fichiers !" 'message de fin
End Sub

Par conséquent, il prend l'extension .xlsm...

Bonjour ThauThème,

Merci pour ta réponse extrèmement rapide, qui répond parfaitement à mon besoin.

J'ai testé et ça marche parfaitement.

Toutefois j'ai une autre question, j'ai le même besoin sur un tableau qui a plus de colonne (9 colonnes contre 3 pour le ficher qui était uploadé).

Qu'elle est la partie du code qu'il faut modifier pour que ces 6 colonnes en plus soient copiées dans les fichiers des agences.

Merci par avance.

C'est bon j'ai trouvé il suffisait de modifier la boucle 3 en 9.

Par contre j'ai une ultime requête, est-il possible d'ajouter une ligne dans le code qui permet de renommer chaque fichier agence dans la forme suivante :" AGENCE - ID PDV"

Le 27/04/2017 à 11:03

Re,

Je me demande parfois pourquoi je commente mes codes !?...

CD.SaveAs (CA & TMP(J) & " - ID PDV.xlsx") 'enregistre-sous le classeur destination CD

Le 28/04/2017 à 14:53

ThauThème a écrit :
Re,
Je me demande parfois pourquoi je commente mes codes !?...
CD.SaveAs (CA & TMP(J) & " - ID PDV.xlsx") 'enregistre-sous le classeur destination CD

Merci pour ta réponse, par contre j'ai modifié cette ligne de code mais le nom du fichier n'a pas été modifé.

Ca reste sur le nom de l'agence.

j'ai également une autre question, sur le fichier global, j'ai des cellules comprennant des chiffres qui commencent par 0.

Mais dans les Fichiers agences celui n'est pas recopié correctement..

Exemple dans le fichier global j'ai '0232' dans le fichier agence il est re copié sous la forme suivante : 232 .

Est-il possible de corriger ce problème ?

Merci par avance.

Le 02/05/2017 à 17:01

Tizahh a écrit :
ThauThème a écrit :
Re,
Je me demande parfois pourquoi je commente mes codes !?...
CD.SaveAs (CA & TMP(J) & " - ID PDV.xlsx") 'enregistre-sous le classeur destination CD
Merci pour ta réponse, par contre j'ai modifié cette ligne de code mais le nom du fichier n'a pas été modifé.
Ca reste sur le nom de l'agence.
j'ai également une autre question, sur le fichier global, j'ai des cellules comprennant des chiffres qui commencent par 0.
Mais dans les Fichiers agences celui n'est pas recopié correctement..
Exemple dans le fichier global j'ai '0232' dans le fichier agence il est re copié sous la forme suivante : 232 .
Est-il possible de corriger ce problème ?
Merci par avance.

Bonjour,

Help please.

Rechercher des sujets similaires à "scinder fichier"