Extraction d'une liste à partir de la valeur d'une cellule

Bonsoir les maîtres du vba

J'ai encore besoin de vos lumières.
Dans un onglet (lotissement), j'ai une liste de données avec des noms qui peuvent changer.

De cette liste, j'aimerai extraire une liste de données par nom en feuille 3.
J'ai créé le programme suivant qui marche en partie (grâce au forum).
Mon probleme est le suivant : quand le nom change de valeur, il me mets des lignes vides (si le nom ne correspond pas à celui en question. Je voudrai supprimer ces lignes vides pour que le nom se mette sur une ligne et les valeurs se placent sur une ligne +1 apres ce nom.(pas de ligne vide inutile)
Je souhaite avoir été clair???

Pouvez vous m'aider?
Cordialement
lps 02

Mon code

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
Option Explicit
 
Sub Test()
    Creer_Liste_SansDoublons Sheets("lotissement").Range("N12:N3000")
End Sub
 
 
 
Sub Creer_Liste_SansDoublons(Plage As Range)
    Dim Cell As Range
    Dim Un As Collection
    Dim i As Long, dl As Long, j As Long, b As Long, derlig As Long
 
    Set Un = New Collection
 
    On Error Resume Next
 
    'Boucle sur la plage de cellule
    For Each Cell In Plage
        'If Cell <> "" Permet de ne pas prendre en compte les cellules vides
        'Un.Add Cell, CStr(Cell) Ajoute le contenu de la cellule dans la collection
        If Cell <> "" Then Un.Add Cell, CStr(Cell)
    Next Cell
 
    On Error GoTo 0
 
    'Boucle sur les éléments de la collection.
    For i = 1 To Un.Count
    dl = Sheets("Feuil3").Range("A" & Sheets("Feuil3").Rows.Count).End(xlUp).Row
 
    Sheets("Feuil3").Range("A" & dl + 2).Value = Un.Item(i)
            j = 12
            derlig = Sheets("Feuil3").Range("A" & Sheets("Feuil3").Rows.Count).End(xlUp).Row
            b = derlig + 2
 
            With Sheets("lotissement")
                While .Range("A" & j) <> ""
                    If .Range("N" & j).Value = Un.Item(i) Then
                    .Range("A" & j & ":M" & j).Copy Destination:=Sheets("Feuil3").Range("A" & b)
                    End If
                    j = j + 1
                    b = b + 1
 
                Wend
            End With
 
    Next i
 
    Set Un = Nothing
End Sub