Sub Test()
Application.ScreenUpdating = False
Dim MonDico As Object, c As Range, I As Integer, Tableau
Set MonDico = CreateObject("Scripting.Dictionary")
For Each c In Sheets("Service1").Range([B1], [B1].End(xlToRight))
If c.Value <> "" Then MonDico.Item(c.Value) = c.Value
Next c
Tableau = MonDico.Items
Call tri(Tableau, 0, MonDico.Count - 1)
Application.SheetsInNewWorkbook = MonDico.Count
Workbooks.Add
Application.SheetsInNewWorkbook = 3
ActiveWorkbook.SaveAs Filename:= _
"C:\Documents and Settings\Administrateur\Bureau\Heures 2009\Récolte des fiches" _
& "\Service1\Fiches individuelles Service1.xls" _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Windows("Base.xls").Activate
For I = 0 To MonDico.Count - 1
Windows("Fiche individuelle.xls").Activate
Sheets("Fiche individuelle").Range("P3").FormulaR1C1 = Tableau(I)
Sheets("Fiche individuelle").Range("B1:P66").Copy
Windows("Fiches individuelles Service1.xls").Activate
With Sheets("Feuil" & I + 1).Range("A1")
.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
Sheets("Feuil" & I + 1).PageSetup.PrintArea = "$A$1:$O$66"
Sheets("Feuil" & I + 1).Name = Tableau(I)
Application.ExecuteExcel4Macro "PAGE.SETUP(,,0.7,0.2,0.2,0.2,,,TRUE,TRUE,1,9,true ,,,,,0.2,0.2,FALSE,FALSE)"
Next I
Windows("Base.xls").Activate
Application.ScreenUpdating = True
End Sub
Sub tri(A, Gauc, Droi) ' Tiré de Jacques Boisgontier
Dim Ref, G, D, Temp
Ref = A((Gauc + Droi) \ 2)
G = Gauc: D = Droi
Do
Do While A(G) < Ref: G = G + 1: Loop
Do While Ref < A(D): D = D - 1: Loop
If G <= D Then
Temp = A(G): A(G) = A(D): A(D) = Temp
G = G + 1: D = D - 1
End If
Loop While G <= D
If G < Droi Then Call tri(A, G, Droi)
If Gauc < D Then Call tri(A, Gauc, D)
End Sub
