Sub CopieObjet()
Dim i As Long, n As Long
[B3:C4].Merge 'au cas où...
If IsError([mem]) Then [E2].Name = "mem"
[B3:C4].Copy [mem]
ThisWorkbook.Names.Add "mem", [mem].Offset(1), Visible:=True
For i = 2 To [mem].Row - 2
If Cells(i, "G") <> "" Then
n = n + 1
[H1].Offset(n) = Cells(i, "G")
End If
Next
ThisWorkbook.Names.Add "Liste", [H2].Resize(n), Visible:=True
End Sub