Sub Essai()
'adapté d'un code de jindon
Dim r As Range
Dim i As Long, rng() As Range, x$
With Sheets(1)
Application.ScreenUpdating = False
Set r = .Columns(2).Find(What:="Name*", After:=.Cells(65536, 2), _
LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not r Is Nothing Then
x = r.Address
Do
i = i + 1: ReDim Preserve rng(1 To i)
Set rng(i) = r
Set r = .Columns(2).Find(What:="Name*", After:=r, _
LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
Loop Until r.Address = x
i = i + 1: ReDim Preserve rng(1 To i)
Set rng(i) = .Cells(Rows.Count, 2).End(xlUp).Offset(1)
For i = LBound(rng) To UBound(rng) - 1
.Range(rng(i), rng(i + 1).Offset(-1)).Copy
rng(i).Offset(, 1).PasteSpecial Transpose:=True
Next
End If
.Columns(3).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
.Columns("A:B").Delete Shift:=xlToLeft
Application.CutCopyMode = False
Application.ScreenUpdating = True
End With
End Sub