VBA - Using InStr to find substring and cut characters into offset cell

[spidaman]

Can anyone help with an error I am getting when using the InStr function please?

I want the code to identify the column with header 'To' which can occur in variable position, then search the 'To' column for a specific substring. For each cell containing the substring I need the Offset.(0, -1) cell value to equal the substring plus all characters to the right of the substring (this will never be more than 20 characters).

To make it clear titRng is my title range, ToRng is my 'To' column range and MyString1 is the substring I want to find.

I have tried this using .Find function but also struggled with that option so am trying to make it work with InStr method.

Sub Action_MyCel_v1()


Dim Mycel As Range, foundCell1 As Range, titRng As Range, ToRng As Range
Dim wb1 As Workbook
Dim ws1 As Worksheet, origTAB1 As Worksheet
Dim MyPos1 As Integer
Dim TargetStr1 As String, MyString1 As String


Set wb1 = ActiveWorkbook
Set ws1 = wb1.Sheets("Messages")


    ws1.Copy After:=Sheets(Sheets.Count)
    Set origTAB1 = ActiveSheet
    origTAB1.Name = "Original Messages"
    
    ws1.Activate
    
    TargetStr1 = "To"
    Set titRng = ws1.Rows(1)


    Set foundCell1 = titRng.Find(What:=TargetStr1, LookIn:=xlValues, _
    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
    MatchCase:=True, SearchFormat:=False)
    
    Set ToRng = foundCell1.EntireColumn
    
    MyString1 = "Name:"
    
    For Each Mycel In ToRng
    
        ' Error thrown on next row
        If InStr(1, Mycel.Value, MyString1) > 0 Then


            MyPos1 = InStr(Mycel, MyString1, 1)
            Mycel.Offset(0, 1).Value = Mid(MyString1, MyPos1, 20)
        
        End If
        
    Next Mycel


End Sub

I assume I can't use MyString1 within the InStr function but if not then how else can I make it work? Also I'd like to actually cut the characters out of the cell rather than just copy them.

Any suggestions welcome and thanks in advance for taking a look.

 

[DanteAmor]

What does the error say?

"run-time error 13 – Type mismatch"

 

[DanteAmor]

Try with this:

Sub Action_Cel()


    Dim sh As Worksheet, f As Range, r As Range, b As Range
    Dim u As Double, cell As String, MyString1 As String
    
    Set sh = Sheets("Messages")
    MyString1 = LCase("Name:")
    
    Set f = sh.Rows(1).Find("To", LookIn:=xlValues, LookAt:=xlPart)
    If Not f Is Nothing Then
        

        'set the range from row 1 to the last row with data from the column where found the word "To"
        u = sh.Cells(Rows.Count, f.Column).End(xlUp).Row
        Set r = sh.Range(sh.Cells(1, f.Column), sh.Cells(u, f.Column))  


        Set b = r.Find(MyString1, LookIn:=xlValues, LookAt:=xlPart)
        If Not b Is Nothing Then
            cell = b.Address
            Do
                b.Offset(0, 1).Value = Mid(b.Value, InStr(1, LCase(b.Value), MyString1))
                Set b = r.FindNext(b)
            Loop While Not b Is Nothing And b.Address <> cell
        Else
            MsgBox "There is no word 'Name:'"
        End If
    Else
        MsgBox "There is no word 'To'"
    End If


End Sub