Your msg wasn't all clear, but the following does what was clear.

Hth,
Merjet

Sub extractTattoo()
Dim iPos1 As Integer
Dim iPos2 As Integer
Dim sstr As String
Dim char As String
Dim iRow As Integer
Dim ws As Worksheet

Set ws = Sheets("Sheet1")
iRow = 4
Do Until ws.Range("A" & iRow) = ""
sstr = ws.Range("A" & iRow)
iPos1 = InStr(1, sstr, "rmd")
iPos2 = InStr(iPos1 + 3, sstr, " ")
If iPos2 = iPos1 + 3 Then iPos2 = InStr(iPos1 + 4, sstr, " ")
char = Mid(sstr, iPos1, iPos2 - iPos1)
ws.Range("J" & iRow) = char
iRow = iRow + 1
Loop
End Sub