Macro para separar texto con condición y que lo ponga por debajo de la celda

En la imagen veras el resultado de la macro

y esta es la macro

Sub separar_numeros()
Set DATOS = Range("a1").CurrentRegion
With DATOS
    F = .Rows.Count
    MATRIZ = DATOS
    X = 1
    For I = 1 To F
        INFO = MATRIZ(I, 1)
        SEPARA = Split(INFO, "|")
        For J = 0 To UBound(SEPARA)
            Range("A1").Cells(X, 1) = SEPARA(J)
            X = X + 1
        Next J
    Next I
End With
Set DATOS = Nothing
End Sub

[Hola 

Te paso la macro 

Sub SEPARA_CADENA()
'
'VALORA LA RESPUESTA PARA FINALIZAR
    Set h1 = Sheets("Hoja1")
    Set h2 = Sheets("Hoja2")
    '
    k = 1
    h2.Cells.ClearContents
    For i = 2 To h1.Range("A" & Rows.Count).End(xlUp).Row
        If InStr(1, h1.Cells(i, "A"), "") > 0 Then
        cad = Split(h1.Cells(i, "A"), "")
        For j = LBound(cad) To UBound(cad)
            h2.Cells(k, "A") = cad(j)
            k = k + 1
        Next j
        End If
    Next i
    MsgBox "Fin"
End Sub