Macro - spliter un fichier Excel en plusieurs

Bonjour,

Je souhaiterai créer une macro pour spliter le fichier excel joint (source) en plusieurs fichiers excel:

- chaque fichier porterait le nom de la colonne F (pas forcément trié en ordre Alphabétique)

exemple:

fichier 1: AB 3EME AILE PEDIATRIQUE

fichier 2 : AB 3EME HOSPI...

• Données à récupérer : colonne "A à H" (en conservant les couleurs de la ligne 1)
• Le listing peut évoluer: ici 397 lignes mais peut évoluer en plus ou moins

Le fichier source sera déposé sur mon bureau dans un dossier "Spliter". Une fois éclatés, les fichiers seront dans le dossier "Spliter"> dossier "Split"(bureau) (C:\Users\wmerbah\Desktop\Spliter)

merci à toutes et tous pour votre aide

lien ici :https://www.cjoint.com/c/HEckkyG1J5Z

Bonjour,

A tester (et adapter à ta convenance).

Sub DécoupageSections()
    Dim wsI As Worksheet, wsE As Worksheet, ss, n&, i%, chD$, nF$
    chD = ThisWorkbook.Path & "\FichiersDécoupés"
    On Error Resume Next
    ChDir chD
    If Err.Number <> 0 Then MkDir chD
    On Error GoTo 0
    chD = chD & "\"
    Set wsI = ActiveSheet
    Application.ScreenUpdating = False
    Set wsE = Worksheets.Add(after:=wsI)
    With wsI
        n = .Range("F" & .Rows.Count).End(xlUp).Row
        .Range("F1:F" & n).AdvancedFilter xlFilterCopy, , .Range("AZ1"), True
        ss = .Range("AZ1").CurrentRegion.Value
        .Range("AZ1").CurrentRegion.Offset(1).Clear
        For i = 2 To UBound(ss)
            nF = Replace(ss(i, 1), "/", " ") & ".xlsx"
            .Range("AZ2") = ss(i, 1)
            .Range("A1:AI" & n).AdvancedFilter xlFilterCopy, .Range("AZ1:AZ2"), wsE.Range("A1:AI1")
            wsE.Copy
            ActiveWorkbook.SaveAs chD & nF
            Workbooks(nF).Worksheets(1).Columns("A:AI").AutoFit
            Workbooks(nF).Close True
            wsE.Range("A1").CurrentRegion.Clear
        Next i
        .Range("AZ1:AZ2").Clear
    End With
    Application.DisplayAlerts = False
    wsE.Delete
End Sub

NB- Les fichiers créés sont enregistrés dans un sous-dossier du dossier contenant le classeur principal, intitulé : FichiersDécoupés.

Cordialement.

C'est juste parfait...

merci beaucoup MFERRAND - je débute sur les macros, je vais tenter de l'adapter sur d'autres fichiers.

je suppose qu'il est possible à l'inverse de tout concatener à partir du dossier "Fichiersdécoupés" ?

Bonjour,

Une autre proposition.

Cdlt.

Public Sub Create_Workbooks()
Dim ws As Worksheet, ws2 As Worksheet
Dim lo As ListObject
Dim n As Long
Dim Cell As Range
Dim sFile As String
Const sFolder As String = "C:\Users\Jean-Eric\Downloads\Spliter\"
Dim flag As Boolean

    Application.ScreenUpdating = False
    With ActiveWorkbook.Worksheets("Donn?es")
        If .Cells(1).ListObject Is Nothing Then
            flag = 1
            Set lo = .ListObjects.Add(xlSrcRange, .Cells(1).CurrentRegion, , xlYes)
            lo.TableStyle = ""
        Else
            Set lo = .ListObjects(1)
        End If
    End With
    If lo.ShowAutoFilter Then lo.AutoFilter.ShowAllData
    Set ws = Worksheets.Add
    With ws
        lo.ListColumns(6).Range.AdvancedFilter _
                Action:=xlFilterCopy, _
                copytorange:=.Cells(1), _
                unique:=True
        n = .Cells(.Rows.Count, 1).End(xlUp).Row
        For Each Cell In .Cells(2, 1).Resize(n - 1)
            sFile = Replace(Cell.Value, "/", "_") & ".xlsx"
            lo.Range.AutoFilter field:=6, Criteria1:="=" & Cell.Value
            Set ws2 = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
            lo.Range.SpecialCells(12).Cells(1, 1).Resize(lo.ListRows.Count, 8).Copy
            With ws2.Cells(1)
                .PasteSpecial xlPasteColumnWidths
                .PasteSpecial xlPasteFormats
                .PasteSpecial xlPasteValues
                Application.CutCopyMode = 0
                .Select
                With ActiveWorkbook
                    .SaveAs sFolder & sFile, 51
                    .Close
                End With
            End With
        Next Cell
    End With
    Application.DisplayAlerts = False
    ws.Delete
    lo.Range.AutoFilter field:=6
    If flag Then lo.Unlist

End Sub

Bonjour,

Bonjour MFerrand, Jean-Eric

je suppose qu'il est possible à l'inverse de tout concatener à partir du dossier "Fichiersdécoupés" ?

Oui, en ouvrant ton classeur d'origine, sans macro, et sans formule

Salut M12 !

Salut à tous !

merci M12 pour cette touche d'humour

l'idée est de rassembler les classeurs du dossier "fichiersdécoupés" sur un seul lorsqu'ils seront complétés...(colonne G et H à compléter par mes cadres)

merci à tous

Personne pour m'aider à tout regrouper une fois découpé et completé?

Merci

C'est tout de même plus simple à faire :

• ouverture tour à tour de chaque classeur du dossier
• récupération du contenu de la première feuille
• ajout de ce contenu dans une feuille d'un classeur cible (le même qu'à l'origine ou un autre) à la suite
• enregistrer le classeur ayant recueilli les données

Cordialement.