Sub Essai()
Dim nlm&, n1&, n2&: nlm = Rows.Count
n2 = Cells(nlm, 2).End(3).Row: If n2 = 1 And IsEmpty([B1]) Then Exit Sub
n1 = Cells(nlm, 1).End(3).Row: Application.ScreenUpdating = 0
If n1 = 1 And IsEmpty([A1]) Then Columns(1).Delete: Exit Sub
Dim T1, T2, k&, i&, j&, p&
T1 = Application.Transpose([A1].Resize(n1))
T2 = Application.Transpose([B1].Resize(n2))
k = n1 + n2: ReDim Preserve T1(1 To k): k = n1: i = 1
Do
For j = 1 To n2
If T2(j) <> "" Then
For p = k To i Step -1: T1(p + 1) = T1(p): Next p
k = k + 1: i = i + 1: T1(i) = T2(j)
End If
i = i + 1
Next j
Loop Until i = k + 1
[A1].Resize(k) = Application.Transpose(T1): Columns(2).Delete
End Sub