Function SheetExists(xsh) As Boolean
'-----------------------------------------------------------
' renvoie TRUE si la feuille existe dans ce classeur
' xsh est soit une variable de type Sheet soit une variable
' de type string représentant le nom de la feuille
'-----------------------------------------------------------
Dim verif
On Error GoTo ExistePAS
verif = ThisWorkbook.Sheets(xsh.Name).Range("a1")
SheetExists = True
Exit Function
ExistePAS:
verif = ThisWorkbook.Sheets(xsh).Range("a1")
SheetExists = True
Exit Function
End Function
Sub Ventiler(NomCol$, NumCol&)
Dim maZone As Range, maCol As Range, xrg As Range
Dim sh As Worksheet
Dim i&, nom$
Dim dico As New Dictionary, maColValue, valeur
Application.ScreenUpdating = False
Set maZone = Sheets("BASE").Range("a4").CurrentRegion
Set maCol = maZone.Columns(NumCol)
'Effacement de toutes les feuilles pour la colonne NomCol
Application.DisplayAlerts = False
For Each sh In ThisWorkbook.Sheets
If sh.Name Like NomCol & "*" Then sh.Delete
Next sh
Application.DisplayAlerts = True
maColValue = maCol.Value
'construction de la liste des items différents de la colonne
For i = 2 To UBound(maColValue)
dico(maColValue(i, 1)) = ""
Next i
'boucle sur les items de la colonne
With Sheets("BASE")
For Each valeur In dico.Keys
Range("A4").AutoFilter
Set sh = ThisWorkbook.Sheets.Add
If VarType(valeur) = 7 Then
sh.Name = NomCol & "-" & [B]Format[/B](valeur, "dd-mm-yy")
Else
sh.Name = NomCol & "-" & valeur
End If
sh.Move after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
.Activate
If VarType(valeur) = 7 Then
.Range("$A$4").AutoFilter Field:=NumCol, Field:=1, Operator:= _
xlFilterValues, Criteria2:=Array(2, Format(valeur, "mm/dd/yyyy"))
Else
.Range("$A$4").AutoFilter Field:=NumCol, Criteria1:=valeur
End If
maZone.SpecialCells(xlCellTypeVisible).Copy sh.Range("a4")
Set xrg = sh.Range("a4").Offset(, NumCol - 1)
Set xrg = xrg.End(xlDown)
Set xrg = sh.Range(sh.Range("a4").Offset(, NumCol - 1), xrg)
xrg.Interior.Color = RGB(256, 64, 64)
Next valeur
.Range("A4").AutoFilter
Application.Goto .Range("a1"), True
Application.CutCopyMode = False
End With
Application.ScreenUpdating = True
End Sub