Filtrer et enregistrer sous en vba

Option Explicit


Sub Ventile()
Dim CurCell As Range, Titre As Range


Application.ScreenUpdating = 0


Columns("A:J").Sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("A2"), Order2:=xlAscending, Header:=xlGuess
Range("A1").Select


Set CurCell = ThisWorkbook.Sheets("Data").Range("B1")
Set Titre = ThisWorkbook.Sheets("Data").Range("A1:J1")


While CurCell.Value <> vbNullString
    With GetSheet(CurCell.Value)
        Titre.EntireRow.Copy .Cells(1, 1)
        CurCell.EntireRow.Copy .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
    End With
    Set CurCell = CurCell.Offset(1, 0)
    Columns("A:J").Columns.AutoFit
Wend


Application.DisplayAlerts = 0
Sheets("Direction").Delete
Application.DisplayAlerts = 1
Sheets("Data").Activate
End Sub


Public Function GetSheet(SheetName As String) As Worksheet
'Cette fonction renvoie la feuille nommée <SheetName> et la crée si elle n'existe pas
Dim CurSheet As Worksheet, Exist As Boolean
Exist = False
For Each CurSheet In ThisWorkbook.Sheets
    If CurSheet.Name = SheetName Then Exist = True
Next CurSheet
If Not Exist Then
    ThisWorkbook.Sheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = SheetName
End If
Set GetSheet = ThisWorkbook.Worksheets(SheetName)
End Function

Option Explicit


Sub Ventile()
Dim CurCell As Range, Titre As Range
Dim Rep


Rep = MsgBox("Voulez vous créer les classeurs ?", vbYesNo)


Application.ScreenUpdating = 0


Columns("A:J").Sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("A2"), Order2:=xlAscending, Header:=xlGuess
Range("A1").Select


Set CurCell = ThisWorkbook.Sheets("Data").Range("B1")
Set Titre = ThisWorkbook.Sheets("Data").Range("A1:J1")


While CurCell.Value <> vbNullString
    With GetSheet(CurCell.Value)
        Titre.EntireRow.Copy .Cells(1, 1)
        CurCell.EntireRow.Copy .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
    End With
    Set CurCell = CurCell.Offset(1, 0)
    Columns("A:J").Columns.AutoFit
Wend
Application.DisplayAlerts = 0
Sheets("Direction").Delete
Application.DisplayAlerts = 1
Sheets("Data").Activate
If Rep = vbYes Then Call Création
End Sub


Sub Création()
Dim X%
For X = 2 To Sheets.Count
Sheets(X).Copy
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & ActiveSheet.Name & ".xls"
    ActiveWorkbook.Close
    Next
    End Sub




Public Function GetSheet(SheetName As String) As Worksheet
'Cette fonction renvoie la feuille nommée <SheetName> et la crée si elle n'existe pas
Dim CurSheet As Worksheet, Exist As Boolean
Exist = False
For Each CurSheet In ThisWorkbook.Sheets
    If CurSheet.Name = SheetName Then Exist = True
Next CurSheet
If Not Exist Then
    ThisWorkbook.Sheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = SheetName
End If
Set GetSheet = ThisWorkbook.Worksheets(SheetName)
End Function

Sub CreerFichiers()
Dim F As Worksheet, h&, d As Object, cel As Range, plage As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si un fichier existe déjà
On Error Resume Next 'si ce fichier est en plus ouvert...
Set F = ThisWorkbook.Sheets("Base")
F.AutoFilterMode = False 'désactive le filtre automatique
h = F.Cells(F.Rows.Count, "B").End(xlUp).Row
If h = 1 Then Exit Sub
Set d = CreateObject("Scripting.Dictionary")
For Each cel In F.[B2].Resize(h - 1)
  If Not d.exists(cel.Value) And cel <> "" Then
    d(cel.Value) = cel.Value
    F.Copy 'copie la feuille dans un nouveau document
    ActiveSheet.Name = CStr(cel) 'ou un autre nom...
    F.[B1].Resize(h).AutoFilter 1, cel
    Set plage = F.[B1].Resize(h).SpecialCells(xlCellTypeVisible)
    F.AutoFilterMode = False
    plage.EntireRow.Copy ActiveSheet.[A1]
    ActiveSheet.Rows(plage.Count + 1 & ":" & Rows.Count).Delete
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & cel 'chemin à adapter
    If Not ActiveWorkbook.Saved Then MsgBox "Fermez le fichier '" & cel & "' !!!", 48
    ActiveWorkbook.Close False 'facultatif
  End If
Next
F.Parent.Activate
End Sub

Sub SauveDirection()
Dim Dico, ListeDir, ColDir As String, Sh As Worksheet, Dossier As String, i as long
    Dossier = "C:\temp\" ' Dossier de destination des fichiers
    ColDir = "B"
    Set Dico = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False
    With Sheets("Base")
        For i = 2 To .Range(ColDir & .Rows.Count).End(xlUp).Row
            Dico(.Cells(i, ColDir).Value) = 1
        Next i
        ListeDir = Dico.Keys
        .Range("IV1").Value = .Range(ColDir & "1").Value
        For i = LBound(ListeDir) To UBound(ListeDir)
            .Range("IV2").Value = ListeDir(i)
            Set Sh = ThisWorkbook.Sheets.Add
            .Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
                CriteriaRange:=.Range("IV1:IV2"), CopyToRange:=Sh.Range("A1"), Unique:=False
            Sh.Name = ListeDir(i)
            Sh.Move
            ActiveWorkbook.SaveAs Filename:=Dossier & ListeDir(i) & ".xls"
            ActiveWorkbook.Close False
        Next i
        .Range("IV1:IV2").ClearContents
    End With
    Application.ScreenUpdating = True
End Sub