Excel VBA help copying and pasting text to a new row

Hello Everyone,

I'm new to Excel VBA would appreciate anyone that is kind enough to help me. I'm trying to write a macro that looks in cell A1:VGH1 for the text "Name:" within the row, then copy that cell and other following cells and paste into a new row. This macro can loop through the row until all instances of the text "Name:" and the following cells are on their own row. Thank you soo much in advance.


What I have currently.

Name:xxx From:xxx Name:xxx To:xxx From:xxx Name:xxx: To:xxx

The result

Name:xxx From:xxxx
Name:xxx To:xxx From:xxxx
Name:xxx To:xxx

Assuming you have your current text in row 1 and want your results in A2 and down, this code should work.

Sub Name_Find()

Dim names() As Long
Set rNa = Range("A1")
iLoop = WorksheetFunction.CountIf(Rows(1), "Name:*")
ReDim names(1 To iLoop)

 For i = 1 To iLoop


  Set rNa = Rows(1).Find(What:="Name:", After:=rNa, _
    LookIn:=xlValues, LookAt:=xlPart, _
    SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
    MatchCase:=False)

    names(i) = rNa.Column
    Cells(i + 1, 1).Value = rNa
    If i <> 1 Then Cells(i + 1, 2).Resize(1, names(i) - names(i - 1) - 1).Value = Range(Cells(1, names(i - 1) + 1), Cells(1, names(i) - 1)).Value

 Next i
End Sub