Sub Professions()
Dim c As Range
Application.ScreenUpdating = False
Range("k:k").Insert
Range("b:d").Clear
Sheets("Saisie").Range("Profession").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("k1"), Unique:=True
Range("k:k").Sort Range("k1"), xlAscending, Header:=xlYes
Do While Range("K2") <> ""
Range("b65536").End(3)(6) = Range("d2")
Sheets("Saisie").Range("b4").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("k1:k2"), CopyToRange:=Range("b65536").End(3)(7), Unique:=False
Range("K2").Delete Shift:=xlUp
Loop
Range("k:k").Delete
For Each c In Range("b2", [b65000].End(xlUp))
If c.Offset(1, 0) = "Nom" Then
With c
.Value = c.Offset(2, 1)
.Interior.ColorIndex = 6
.Borders.Value = 1
End With
End If
Next
Range("c:c").Delete
For Each c In Range("b2", [b65000].End(xlUp))
If c = "Nom" Then c.EntireRow.Delete
Next
Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub