VBA - search a string in row then copy & paste it to a different column

Question

_As a newby at VBA, I am trying to search for specific strings in a row from column D then copy it and paste that string in a different column. I have about 10,000 entries so manually doing it is not efficient. Strings I'm looking for are "REQ0"s and "RITM0"s.

This is my current code:

Option Compare Text
Public Sub Search_For()
Dim cursht

cursht = ActiveSheet.Name
row_number = 1

Do

row_number = row_number + 1
item_description = Sheets(cursht).Range("D" & row_number)
items_copied = Sheets(cursht).Range("F" & row_number)

If InStr(item_description, "REQ0") Then
    Worksheets("cursht").Row(item_description).Copy
    items_copied.Paste
If InStr(item_description, "RITM") Then
    Worksheets("cursht").Row(item_description).Copy
    items_copied.Paste
End If

Loop Until items_description = ""

End Sub

Expected results:

Answer 1

Well, here is a way to do it:

Sub Test()

Dim X As Long, LR As Long, POS1 As Long, POS2 As Long

With ActiveWorkbook.Sheets(1)
    LR = .range("D" & Rows.Count).End(xlUp).Row
    For X = 2 To LR
        If InStr(1, .Cells(X, 4), "REQ0") > 0 Then
            POS1 = InStr(1, .Cells(X, 4), "REQ0") 'Get startposition
            POS2 = InStr(POS1, .Cells(X, 4), " ") 'Get positon of space
            If POS2 > 0 Then 'In case there is a space
                .Cells(X, 5) = Mid(.Cells(X, 4), POS1, POS2 - POS1)
            Else 'In case the found value is at end of string
                .Cells(X, 5) = Right(.Cells(X, 4), Len(.Cells(X, 4)) - (POS1 - 1))
            End If
        End If
        If InStr(1, .Cells(X, 4), "RITM") > 0 Then 'Repeat same process for "RITM"
            POS1 = InStr(1, .Cells(X, 4), "RITM")
            POS2 = InStr(POS1, .Cells(X, 4), " ")
            If POS2 > 0 Then
                .Cells(X, 6) = Mid(.Cells(X, 4), POS1, POS2 - POS1)
            Else
                .Cells(X, 6) = Right(.Cells(X, 4), Len(.Cells(X, 4)) - (POS1 - 1))
            End If
        End If
    Next X
End With

End Sub

Using Copy/Paste would slow down your procedure significantly.

EDIT

A better way might be to just use formulas

Type this formula in E2:

=IF(ISNUMBER(SEARCH("*REQ0*",D2)),MID(D2,FIND("REQ0",D2),11),"")

And put this formula in F2:

=IF(ISNUMBER(SEARCH("*RITM*",D2)),MID(D2,FIND("RITM",D2),11),"")

Drag both down...