XL 2016 Découpage Fichier Excel en plusieurs Fichiers selon une clé - VBA

[Popov63]

Bonjour à tous!

Je cherche à découper un fichier excel en plusieurs fichiers suivant une clé.

La clé est en colonne A, et dès lors que la clé change je souhaite qu'Excel fasse les opérations ci-dessous et enregistre le fichier sous le nom "TEST2 Bordereau des Responsables d'UO - XXXXX.xlsm" où XXXX est le nom de ma clé.

J'ai tenté de faire une loop en définissant une variable mais je suis trop mauvais en VBA..

Merci d'avance pour votre aide,

Pierre

Sub TEST()
'
' TEST Macro
'

'
    Sheets("Bordereau_cible").Select
    Range("A1:A8").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    Columns("O:O").ColumnWidth = 16.36
    Columns("P:P").ColumnWidth = 19.45
    Columns("Q:Q").ColumnWidth = 19.82
    Columns("R:R").ColumnWidth = 24.91
    Sheets("Feuil1").Select
    Sheets("Feuil1").Name = "Bordereau"
    Range("A1").Select
    Sheets("Bordereau_cible").Select
    Application.CutCopyMode = False
    ActiveWindow.SelectedSheets.Delete
    Sheets("Annexes").Select
    ActiveWindow.SelectedSheets.Visible = False
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    ActiveWorkbook.Protect Structure:=True, Windows:=False
    ChDir "C:\Desktop\Téléchargement"
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Desktop\Téléchargement\TEST2  Bordereau des Responsables d'UO - EHP001.xlsm" _
        , FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    ActiveWorkbook.Save
End Sub

 

[fanch55]

Bonjour,
Le code ci-joint remplit ce que vous semblez vouloir décrire ( mais peut-être pas ce que vous désirez )

Sub Test()
Path = "C:\Desktop\Téléchargement\"
' Path = ThisWorkbook.Path & "\"

    With [Tableau1].ListObject
        For I = 1 To 999
            .Range.AutoFilter Field:=1, Criteria1:="=EHP" & Format(I, "000") & "*"
            For Each Plage In .Range.SpecialCells(xlCellTypeVisible).Areas
                If Not Intersect(Plage, .DataBodyRange) Is Nothing Then
                    .Range.SpecialCells(xlCellTypeVisible).Copy
                    With Workbooks.Add().ActiveSheet
                        .Name = "Bordereau"
                        .Cells.PasteSpecial xlPasteColumnWidths
                        .Cells.PasteSpecial xlPasteAll
                        .SaveAs Filename:=Path & "EHP" & Format(I, "000") & ".xlsm", _
                                FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
                    End With
                    ActiveWorkbook.Close False
                    Application.CutCopyMode = False
                    Exit For
                End If
            Next
            .Parent.Select
        Next
        .Range.AutoFilter Field:=1
    End With
End Sub