Copier Coller suivant Condition

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