Cutting and Pasting Range Based on Text in Column to the Left (Updated)

[FrenchCelt]

I need to code my macro to look for 4STOP or 3STOP in Row 3 and then cut all data in the next column and paste in Row 16 of the column where the 4STOP/3STOP is located.

For example, I have a 4STOP in Column D. I need to then cut E1:E14 and paste in D17 and then move on to the next 4STOP/3STOP and repeat. I need the emptied column deleted and I need to make sure the data from Row 1 in included in the cut/paste.

Any suggestions?

 

[JLGWhiz]

If this pastes to the wrong row, you can change it on this line:

Intersect(.UsedRange, Columns(fn.Column + 1)).Cut .Cells(17, fn.Column)

Just change the 17 to the row you want. Change in two places.

Sub t()
Dim fn As Range, adr As String
    With ActiveSheet
        Set fn = .Rows(3).Find("4STOP", , xlValues, xlWhole)
            If Not fn Is Nothing Then
                adr = fn.Address
                Do
                    Intersect(.UsedRange, Columns(fn.Column + 1)).Cut .Cells(17, fn.Column)
                    Set fn = .Rows(3).FindNext(fn)
                Loop While fn.Address <> adr
                Set fn = Nothing
            End If
        Set fn = .Rows(3).Find("3STOP", , xlValues, xlWhole)
            If Not fn Is Nothing Then
                adr = fn.Address
                Do
                    Intersect(.UsedRange, Columns(fn.Column + 1)).Cut .Cells(17, fn.Column)
                    Set fn = .Rows(3).FindNext(fn)
                Loop While fn.Address <> adr
                Set fn = Nothing
            End If
        .Range("A3", .Cells(3, Columns.Count).End(xlToLeft)).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete
    End With
End Sub

 

[FrenchCelt]

Thank you! That worked perfectly.

 

[JLGWhiz]

You're welcome,
regards, JLG