XL 2010 Séparer un fichier en plusieurs, en fonction de la valeur d'une colonne

Jaden · 2 Août 2016

Bonjour à tous,

J'ai un fichier correspondant à une liste de client, avec les informations les concernant. L'une des colonnes contenant la date du rendez-vous avec le client.
Je souhaiterait séparer ce fichier, et créer un nouveau fichier pour chaque date, qui regroupe toutes les lignes des clients ayant rendez-vous à cette date.

J'ai réussi à créer des nouveaux onglets avec ce fonctionnement mais je préfèrerais créer des nouveaux fichiers.
J'arrive à créer les fichiers, mais je ne parviens pas à rajouter les nouvelles lignes à un fichier déjà créé, cela me propose sans cesse de créer un nouveau fichier qui écrase le précédent.

VB:

Sub ParseItems()
'Based on selected column, data is filtered to individual workbooks
'workbooks are named for the value plus today's date
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, SvPath As String
Dim contenu As String

'Sheet with data in it
   Set ws = Sheets("export_intervention_client")

'Path to save files into, remember the final \
    SvPath = "\"

'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
    vTitles = "A1:BH1"

'Choose column to evaluate from, column A = 1, B = 2, etc.
  ' vCol = Application.InputBox("What column to split data by? " & vbLf _
     '   & vbLf & "(A=1, B=2, C=3, etc)", "Which column?", 1, Type:=1)
  ' If vCol = 0 Then Exit Sub
                        vCol = 31
'Spot bottom row of data
   LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row

'Speed up macro execution
   Application.ScreenUpdating = False

'Get a temporary list of unique values from key column
    ws.Columns(vCol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True

'Sort the temporary list
    ws.Columns("EE:EE").Sort Key1:=ws.Range("EE2"), Order1:=xlAscending, Header:=xlYes, _
       OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

'Put list into an array for looping (values cannot be the result of formulas, must be constants)
    MyArr = Application.WorksheetFunction.Transpose(ws.Range("EE2:EE" & Rows.Count).SpecialCells(xlCellTypeConstants))

'clear temporary worksheet list
    ws.Range("EE:EE").Clear

'Turn on the autofilter, one column only is all that is needed
    ws.Range(vTitles).AutoFilter

'Loop through list one value at a time
    For Itm = 2 To UBound(MyArr)
        ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)
    
        ws.Range("A1:A" & LR).EntireRow.Copy
        Workbooks.Add
        Range("A1").PasteSpecial xlPasteAll
        Cells.Columns.AutoFit
        MyCount = MyCount + Range("AE" & Rows.Count).End(xlUp).Row - 1
        contenu = ws.Cells(Itm, 31).Value
    
        'ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & Format(Date, "ddmmyyyy"), xlNormal
        'ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & Format(Date, "ddmmyyyy") & ".xlsx", 51
        ActiveWorkbook.SaveAs Filename:=Format(contenu, "dd-mm-yyyy") & " Export planning" 'use for Excel 2007+
        ActiveWorkbook.Close
    
        ws.Range(vTitles).AutoFilter Field:=vCol
    Next Itm

'Cleanup
    ws.AutoFilterMode = False
    MsgBox "Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: " & MyCount & vbLf & "Hope they match!!"
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
End Sub

Est-ce mieux si j'upload aussi mon fichier?

Merci d'avance,

Jaden

Paf · 2 Août 2016

Bonjour Jaden et bienvenue sur XLD,

Oui un classeur joint permettrait de mieux visualiser ce qui se passe.

Un doute avec ActiveWorkbook.SaveAs Filename:=Format(contenu, "dd-mm-yyyy") & " Export planning" :
peut-être la variable contenu est identique pour chaque classeur créé, et donc le nom de ce classeur sera toujours identique ce qui pourrait expliquer l''écrasement' ...

A+

Jaden · 2 Août 2016

Il faudrait que je puisse effectuer un test pour voir si le fichier existe déjà et dans ce cas, seulement ajouter la ligne à la suite, mais je ne vois pas comment faire.

J'ai fait comme ci-dessous pour le faire avec les onglets mais je n'arrive pas à l’adapter pour des fichiers :

Code:

If FeuilleExiste(ThisWorkbook, contenu) Then
            .Rows(lig).Copy Sheets(contenu).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
        Else
            Sheets.Add
            ActiveSheet.Name = contenu
            .Rows(1).Copy Sheets(contenu).Range("A1") 'copie/colle la 1ère ligne en 1ère ligne
            .Rows(lig).Copy Sheets(contenu).Range("A2") 'copie/colle la ligne trouvée en 2ème ligne
        End If

PS : J'ai ajouté le fichier au premier post.

Paf · 2 Août 2016

Re,

c'est effectivement un problème de dates identiques qui donnent leur nom au fichier, car vous lister toutes les dates de la colonne AE et pour chaque date vous tenter de créer un classeur ( contenant toutes les lignes de cette date).

La solution consiste à 'lister' les dates uniques de cette colonne , le reste sans changement.

Un souci cependant les dates sont de la forme 10/06/16 08:00

et pour les lignes 4,5 et 6 on trouve
10/06/16 08:00
10/06/16 12:00
10/06/16 14:00

elles sont différentes, et vont générer 3 classeurs différents; mais quand vous écrivez :
ActiveWorkbook.SaveAs Filename:=Format(contenu, "dd-mm-yyyy") & " Export planning" (contenu étant initialisé des valeurs ci dessus)

le nom du fichier créé pour chacune des lignes sera 10-06-2016 Export planning . donc souci ...

Deux solutions:
1) on tient compte de l'heure et on crée des classeurs dont le nom contient également l'heure
2) on ne tient compte que de la date et pour chaque date on crée un classeur contenant toutes les lignes de cette date ( sans tenir compte de l'heure.

dans le deuxième cas il y a quelques aménagements de code à réaliser.

A vous de dire.

A+

Jaden · 2 Août 2016

Il ne faut pas tenir compte de l'heure, je veux juste faire un fichier par jour, contenant toutes les lignes de cette date.
Mais le tableau étant rempli comme ca, je ne sais pas comment garder seulement la partie avec la date dans cette case.

Paf · 2 Août 2016

Re,

Un essai à tester et adapter (notamment au niveau nom de feuille et répertoire où copier les classeurs:

VB:

Sub ParseItems()
'Based on selected column, data is filtered to individual workbooks
'workbooks are named for the value plus today's date
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, SvPath As String
Dim contenu As String
Dim Dico, Plage As Range

Set Dico = CreateObject("Scripting.Dictionary")

'Sheet with data in it
   'Set ws = Sheets("export_intervention_client")
   Set ws = Sheets("Feuil1")  'à adapter  <======

'Path to save files into, remember the final \
    SvPath = "C:\Documents and Settings\...\...\...\" 'à adapter  <======

'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
    vTitles = "A1:AF1"
 
'Choose column to evaluate from, column A = 1, B = 2, etc.
  ' vCol = Application.InputBox("What column to split data by? " & vbLf _
     '   & vbLf & "(A=1, B=2, C=3, etc)", "Which column?", 1, Type:=1)
  ' If vCol = 0 Then Exit Sub
    vCol = 31
'Spot bottom row of data
   LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row
'détermine la plage du tableau
    Set Plage = ws.Range("A1:AF" & LR)
'désactive le rafraichissement écran, évite le 'scintillement' et traitement + rapide
   Application.ScreenUpdating = False

'Turn on the autofilter, one column only is all that is needed
'met la feuille  en mode filtre si elle ne l'est pas
    If Not ws.AutoFilterMode Then Plage.AutoFilter
  


'Tri du tableau selon col AE croissant
    Plage.Sort Key1:=Range("AE1"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1


'Put list into an array for looping (values cannot be the result of formulas, must be constants)
'création d'un dictionnaire contenant les dates uniques
    MyArr = ws.Range("AE2:AE" & LR)
    For i = LBound(MyArr) To UBound(MyArr)
        Dico(Left(MyArr(i, 1), 8)) = ""
    Next

'Loop through list one value at a time
'boucle sur chaque clé du dictionnaire (date )
    For Each clé In Dico.keys
        Plage.AutoFilter Field:=vCol, Criteria1:=clé & "*"
        With Workbooks.Add
         With .Worksheets(1)
          Plage.Copy .Range("A1")
          .Columns.AutoFit
          MyCount = MyCount + .Range("AE" & Rows.Count).End(xlUp).Row - 1
         End With
         contenu = Format(CDate(clé), "dd-mm-yyyy")
         'ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & Format(Date, "ddmmyyyy"), xlNormal
         'ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & Format(Date, "ddmmyyyy") & ".xlsx", 51
         .SaveAs Filename:=SvPath & contenu & " Export planning" 'use for Excel 2007+
         .Close
        End With
        Plage.AutoFilter Field:=vCol
    Next

'Cleanup
    ws.AutoFilterMode = False
    MsgBox "Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: " & MyCount & vbLf & "Hope they match!!"
  
    'rétabli rafraichissement ecran
    Application.ScreenUpdating = True
  
End Sub

A+

Jaden · 2 Août 2016

C'est parfait! Merci beaucoup pour ton aide, rapide et efficace!

J'ai parlé trop vite, quand j'ai voulu la refaire, j'ai l'erreur suivante :
"Erreur d'exécution 1004" La méthode AutoFilter de la classe Range a échoué.

et ca pointe sur la ligne :

Code:

Plage.AutoFilter Field:=vCol, Criteria1:=clé & "*"

PS : ca s'est passé lorsque j'ai voulu rajouter une ligne en bas

EDIT : j'ai trouvé le problème, si on met déjà un filtre sur une colonne, c'est ca qui bloque

Donc merci encore

XL 2010 Séparer un fichier en plusieurs, en fonction de la valeur d'une colonne

Jaden

XLDnaute Nouveau

Pièces jointes

Paf

XLDnaute Barbatruc

Jaden

XLDnaute Nouveau

Paf

XLDnaute Barbatruc

Jaden

XLDnaute Nouveau

Paf

XLDnaute Barbatruc

Jaden

XLDnaute Nouveau

Discussions similaires