shift segment of a rows to next rows

[excel_learner_vba]

[TABLE="width: 417"]
<colgroup><col><col><col><col><col></colgroup><tbody>[TR]
[TD]Data looks as below[/TD]
[TD] [/TD]
[TD="colspan: 3"]want it as below[/TD]
[/TR]
[TR]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]May 05 2019[/TD]
[TD] [/TD]
[TD]May 05 2019[/TD]
[TD]Jun 17 2019[/TD]
[TD]Aug 9 2019[/TD]
[/TR]
[TR]
[TD]a[/TD]
[TD] [/TD]
[TD]a[/TD]
[TD]e[/TD]
[TD]sg[/TD]
[/TR]
[TR]
[TD]rs[/TD]
[TD] [/TD]
[TD]rs[/TD]
[TD]a[/TD]
[TD]dgh[/TD]
[/TR]
[TR]
[TD="align: right"]1[/TD]
[TD] [/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]45[/TD]
[TD="align: right"]1234[/TD]
[/TR]
[TR]
[TD][+1][/TD]
[TD] [/TD]
[TD][+1][/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]Jun 17 2019[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]e[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]a[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD="align: right"]45[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]Aug 9 2019[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]sg[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]dgh[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD="align: right"]1234[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
</tbody>[/TABLE]


I am just stuck with this. Could you please give me a macro code or some other method to do this? thank you very much!

 

[igold]

Hi excel_learner_vba,

Welcome to the MrExcel Forum. This code works with the data you provided above. The only caveat is that you must continue to use the standard 3 letter abbreviation for the names of the months.

Also, this code will delete data that is not recoverable, please test this on a backup copy of your work.

Sub MoveText()


    Dim arr, pos, mns
    Dim val As String
    Dim lRow As Long, i As Long, c As Long, r As Long


    mns = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
    lRow = Cells(Rows.Count, 1).End(xlUp).Row
    arr = Range("A1:A" & lRow)
    Range("A1:A" & lRow).ClearContents
    For i = LBound(arr) To UBound(arr)
        val = Left(arr(i, 1), 3)
        pos = Application.Match(val, mns, False)
        If Not IsError(pos) Then
            r = 1
            c = c + 1
            Cells(r, c) = arr(i, 1)
            r = r + 1
        Else
            Cells(r, c) = arr(i, 1)
            r = r + 1
        End If
    Next


End Sub

I hope this helps...