Diviser un fichier en plusieurs en fonction d'une valeur

Bonjour à toutes et à tous,

Je viens de parcourir bon nombre de sujet sur ce forum (en autre) et aucun ne répond réellement à ma problématique. Du coup, je viens de m'inscrire sur votre forum pour tenter d'avoir une réponse.

La problématique est la suivante :

  • J'ai un fichier Excel contenant un certain nombre de ligne (entre 5000 et 8000).
  • La colonne G comporte une valeur (exemple: 01, 02, 2A, 988, 59H, etc), obtenu par une formule écrite en VBA.
  • Le nombre de valeur différente de la colonne G est d'environ 110 valeurs (mais cela peut varier).
  • Mon document est trié par la colonne G, donc toutes les lignes ayant la cellule G avec "01" sont regroupées, et ainsi de suite.

Ce que je souhaite obtenir :

  • Un fichier Excel par valeur de la colonne G, par exemple avoir un fichier Excel avec toutes les lignes dont la cellule G comporte "01", un autre fichier Excel avec toutes les lignes dont la cellule G comporte "02", et ainsi de suite jusqu'à la fin de tableau Excel initial.
  • Si en prime, le nouveau fichier ainsi créé pouvait s'enregistrer tout seul dans un dossier (sur le bureau) avec pour nom "FIC"+valeur de la cellule G (par exemple "FIC01.XLS").
  • Et enfin, copier pour chaque fichier généré, la première ligne d'entête du fichier initial.

Le soucis est que je ne sais pas trop comment traiter tout ça... Donc si une âme charitable pouvait m'aider à régler ce problème... ça sera hyper sympa de votre part.

D'avance merci à vous tous.

Cordialement,

67test.xlsx (20.34 Ko)

Bonjour et bienvenue,

Merci de joindre un fichier à ta demande.

Cdlt.

bonjour et bienvenu

il faut utiliser les filtres elaborés

voir un exemple déjà fait :

https://forum.excel-pratique.com/excel/macro-vba-creation-d-autant-de-fichiers-qu-il-y-a-des-code-t63202.html

fred

Jean-Eric a écrit :

Bonjour et bienvenue,

Merci de joindre un fichier à ta demande.

Cdlt.

Désolé, j'avais oublié de joindre le fichier exemple...


fred2406 a écrit :

bonjour et bienvenu

il faut utiliser les filtres elaborés

voir un exemple déjà fait :

https://forum.excel-pratique.com/excel/macro-vba-creation-d-autant-de-fichiers-qu-il-y-a-des-code-t63202.html

fred

Merci pour le lien Fred, je vais lire tout ça... Et revenir vers vous ensuite (je ne suis pas sur de tout comprendre la ).

Re,

Une première proposition à étudier.

La procédure va créer un dossier CP dans le répertoire du classeur actif.

J'ai déclaré toutes les données en tableaux (Excel 2007+) !?

Cdlt.

185test.xlsm (28.45 Ko)
Jean-Eric a écrit :

Re,

Une première proposition à étudier.

La procédure va créer un dossier CP dans le répertoire du classeur actif.

J'ai déclaré toutes les données en tableaux (Excel 2007+) !?

Cdlt.

Je vous remercie pour ce fichier... Petite question subsidiaire... Comment puis je intégrer votre code dans ma macro ?

Re,

1 - Le résultat répond il à tes attentes?

2 - Je ne comprends pas bien :

Comment puis je intégrer votre code dans ma macro ?

Jean-Eric a écrit :

Re,

1 - Le résultat répond il à tes attentes?

2 - Je ne comprends pas bien :

Comment puis je intégrer votre code dans ma macro ?

1 - Le résultat est bon oui... Merci beaucoup

2 - J'ai une macro existante qui traite le fichier d'origine (notamment la détermination du CP, mais également le tri, etc), et j'aimerai intégrer votre fichier à cette macro afin que l'utilisateur final n'est qu'un bouton à cliquer et que tout se fasse "tout seul".

La macro est dans le classeur PERSONAL.XLSB

Re,

Recopie cette procédure dans un module standard de ton PERSONAL.XLSB.

Puis dans la barre d'accès rapide, tu ajoutes un bouton que tu rattaches à cette procédure.

Attention à la partie surlignée (je ne suis pas expert!). On supprime le répertoire CP et ses fichiers si celui-ci existe!?.

A te relire.

Option Explicit
'Option Private Module

Public Sub CopyToWorkbooks()
Dim wb As Workbook
Dim ws As Worksheet, ws2 As Worksheet, WSNew As Worksheet
Dim lo As ListObject
Dim Cell As Range
Dim Lrow As Long, FileFormatNum As Long, FieldNum As Long
Dim sFolderName As String, sPath As String, FileExtStr As String
Dim fso As Object
Dim CalcMode As XlCalculation

    Set wb = ActiveWorkbook
    Set ws = wb.ActiveSheet
    Set lo = ws.ListObjects(1)
    FieldNum = 7

    If lo.ShowAutoFilter Then
        lo.AutoFilter.ShowAllData
    End If

    FileExtStr = ".xlsx": FileFormatNum = 51

    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
        .ScreenUpdating = False
        '.EnableEvents = False
    End With

    On Error Resume Next
    wb.Worksheets("Temp").Delete
    On Error GoTo 0

    Set ws2 = wb.Worksheets.Add(after:=Sheets(Sheets.Count))
    ws2.Name = "Temp"

    sPath = wb.Path & Application.PathSeparator
    sFolderName = sPath & "CP"
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.folderexists(sFolderName) Then
        fso.deletefolder (sFolderName)
    End If 
    MkDir sFolderName & Application.PathSeparator

    With ws2
        lo.ListColumns(FieldNum).Range.AdvancedFilter _
                Action:=xlFilterCopy, _
                CopyToRange:=.Range("A1"), Unique:=True
        Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
        For Each Cell In .Range("A2:A" & Lrow)
            lo.Range.AutoFilter Field:=FieldNum, Criteria1:="=" & Cell.Value
            Set WSNew = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
            lo.Range.SpecialCells(xlCellTypeVisible).Copy
            With WSNew.Range("A1")
                .PasteSpecial xlPasteColumnWidths
                .PasteSpecial xlPasteValuesAndNumberFormats
                Application.CutCopyMode = False
                .Select
            End With
            With WSNew
                .ListObjects.Add(xlSrcRange, .Cells(1, 1).CurrentRegion, , xlYes).Name = "tbl_" & Cell.Value
                .ListObjects(1).TableStyle = "TableStyleLight8"
            End With
            WSNew.Parent.SaveAs sFolderName & Application.PathSeparator & Cell.Value & FileExtStr, FileFormatNum
            WSNew.Parent.Close False
            lo.Range.AutoFilter Field:=FieldNum
        Next Cell
        .Delete
    End With

    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
        '.EnableEvents = True
        .Calculation = CalcMode
    End With

    Set fso = Nothing
    Set lo = Nothing
    Set WSNew = Nothing: Set ws2 = Nothing: Set ws = Nothing
    Set wb = Nothing

End Sub

J'ai copié les lignes dans "Module1" de PERSONAL.XLSB sans problème, mais...

A l’exécution de celle-ci j'ai une erreur à la ligne "Set lo = ws.ListObjects(1)"

Avec une fenêtre indiquant "Erreur d'exécution 9", "L'indice n'appartient pas à la sélection"

Re,

J'ai précisé que j'avais déclaré les données en tableau (mettre sous forme de tableau, à partir de Excel 2007).

Cdlt.

Jean-Eric a écrit :

Re,

J'ai précisé que j'avais déclaré les données en tableau (mettre sous forme de tableau, à partir de Excel 2007).

Cdlt.

Les données sont déjà sous forme de tableau. Pardon mais je ne comprends pas trop la.

En cherchant un peu, je viens de trouver... Je teste tout ça et vous tiens au courant. Encore merci pour votre superbe travail !

Vérification faite, tout fonctionne parfaitement ! Un GRAND merci à Jean-Eric pour son superbe travail !

Merci et à bientôt

Rechercher des sujets similaires à "diviser fichier fonction valeur"