Sub Разбить()

    Dim arr1(), arr2(), lr As Long, i As Long, r As Long
    
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    
    arr1() = Range("A1:B" & lr).Value
    For i = 2 To UBound(arr1)
        If IsNumeric(arr1(i, 1)) = True Then
            arr1(i, 2) = arr1(i, 1)
            arr1(i, 1) = Null
        Else
            arr1(i, 2) = arr1(i - 1, 2)
        End If
    Next i
    
    ReDim arr2(1 To UBound(arr1), 1 To 2)
    For i = 2 To UBound(arr1)
        If IsNull(arr1(i, 1)) = False Then
            r = r + 1
            arr2(r, 1) = arr1(i, 2)
            arr2(r, 2) = arr1(i, 1)
        End If
    Next i
    
    Range("D2").Resize(r, 2).Value = arr2()
    
    MsgBox "Готово!", vbInformation
    
End Sub