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

S

spidaman

Board Regular
Joined
Jul 26, 2015
Messages
116
Office Version
  1. 365
Platform
  1. Windows
Can anyone help with an error I am getting when using the InStr function please? :confused:

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.

Code: 
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.
 

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.
Sort by date Sort by votes
Try changing your 'LookAt:=xlWhole' to 'LookAt:=xlPart'. But if any of your other header before the target header has 'To'' in it, it will give you that cell for a return value.

If you could post and example of the headers you are searching, it would help determine the best approach.
 
Upvote 0
Hi JLGWhiz thanks for your reply.

Typical column headers here:

[TABLE="width: 674"]
<tbody>[TR]
[TD="class: xl63, width: 75, align: left"]Application[/TD]
[TD="class: xl63, width: 64, align: left"]Direct[/TD]
[TD="class: xl63, width: 64, align: left"]Time[/TD]
[TD="class: xl63, width: 64, align: left"]Thread ID[/TD]
[TD="class: xl63, width: 64, align: left"]To[/TD]
[TD="class: xl63, width: 64, align: left"]Created[/TD]
[TD="class: xl63, width: 64, align: left"]Type[/TD]
[TD="class: xl63, width: 151, align: left"]Related ID[/TD]
[TD="class: xl63, width: 64, align: left"]From
[/TD]
[/TR]
</tbody>[/TABLE]


I hadn't thought of an error in finding 'foundCell1' in 'TitRng' tbh.

Have tried changing to xlPart but still raising an error.

Thanks
 
Upvote 0
Try just this for the find statement.

Code: 
Set foundCell1 = titRng.Find(TargetStr1, xlValues, xlWhole)
One problem was you were searching by rows, so it probably only checked the first cell.
 
Upvote 0
I think the problem is you set ToRng as an entire column
Code: 
Set ToRng = foundCell1.EntireColumn

You should limit the range within the last row with data, something like this:

Code: 
Dim x As Long
    x = foundCell1.Column
    Set ToRng = Range(Cells(2, x), Cells(Rows.count, x).End(xlUp))
 
Upvote 0
I think it was too late last night when I was looking at this. I re-read the OP and think maybe this version will work.

Code: 
Sub Action_MyCel_v2()
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 = Intersect(foundCell1.EntireColumn, ws1.UsedRange)
    MyString1 = "Name:"
    For Each Mycel In ToRng
        ' Error thrown on next row
        If InStr(Mycel.Value, MyString1) > 0 Then
            MyPos1 = InStr(Mycel, MyString1)
            Mycel.Offset(0, 1).Value = Mid(Mycel.Value, MyPos1, 20)
        End If
    Next Mycel
End Sub
 
Upvote 0
JLGWhiz said:
I think it was too late last night when I was looking at this. I re-read the OP and think maybe this version will work.

Code: 
Sub Action_MyCel_v2()
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 = Intersect(foundCell1.EntireColumn, ws1.UsedRange)
    MyString1 = "Name:"
    For Each Mycel In ToRng
        ' Error thrown on next row
        If InStr(Mycel.Value, MyString1) > 0 Then
            MyPos1 = InStr(Mycel, MyString1)
            Mycel.Offset(0, 1).Value = Mid(Mycel.Value, MyPos1, 20)
        End If
    Next Mycel
End Sub
Click to expand...
Except for creating the "Original Messages" worksheet (not sure I see a reason to do that) and if I am not mistaken, I believe the following code should do the same thing as your above code does...
Code: 
[table="width: 500"]
[tr]
	[td]Sub Action_MyCel_v3()
  Dim Col As Long, MyString1 As String
  MyString1 = "Name:"
  Col = Rows(1).Find("To", , xlValues, xlWhole, , , True, , False).Column
  With Range(Cells(2, Col), Cells(Rows.Count, Col).End(xlUp)).Offset(, 1)
    .Offset(, -1).Copy .Cells
    .Value = Evaluate(Replace(Replace("IF(@="""","""",REPLACE(@,1,SEARCH(""#"",@&""#"")-1,""""))", "@", .Address), "#", MyString1))
  End With
End Sub[/td]
[/tr]
[/table]
 
Last edited:
Upvote 0
In case the OP can't unscramble the condensed code.

Code: 
Sub Action_MyCel_v3()
Dim Col As Long, MyString1 As String
MyString1 = "Name:"
Col = Rows(1).Find("To", , xlValues, xlWhole, , , True, , False).Column
    With Range(Cells(2, Col), Cells(Rows.Count, Col).End(xlUp)).Offset(, 1)
        .Offset(, -1).Copy [COLOR=#ff0000]'Not sure what this is for[/COLOR]
        .Cells .Value = Evaluate(Replace(Replace("IF(@="""","""",REPLACE(@,1,SEARCH(""#"",@&""#"")-1,""""))", "@", .Address), "#", MyString1))
    End With
End Sub
 
Last edited:
Upvote 0
JLGWhiz said:
Code: 
        .Offset(, -1).Copy [COLOR=#ff0000]'Not sure what this is for[/COLOR]
End Sub
Click to expand...

Without it, the Evaluate function cannot access the values in the range and you get an empty results array. Not sure why.
 
Upvote 0
Code: 
[TABLE="width: 500"]
<tbody>[TR]
[TD]Sub Action_MyCel_v3()
  Dim Col As Long, MyString1 As String
  MyString1 = "Name:"
  Col = Rows(1).Find("To", , xlValues, xlWhole, , , True, , False).Column
  With Range(Cells(2, Col), Cells(Rows.Count, Col).End(xlUp)).Offset(, 1)
    .Offset(, -1).Copy .Cells
    .Value = Evaluate(Replace(Replace("IF(@="""","""",REPLACE(@,1,SEARCH(""#"",@&""#"")-1,""""))", "@", .Address), "#", MyString1))
  End With
End Sub[/TD]
[/TR]
</tbody>[/TABLE]
Click to expand...
@Rick Rothstein - thanks very much! This code does what I was trying to do (just needed to change the column Offset.

The creation of the "Original Messages" worksheet is just to retain copy of the original worksheet (a back-up without creating another file).

I am not familiar with the way you have used the Evaluate function here:
Code: 
[COLOR=#333333][FONT=monospace]Evaluate(Replace(Replace("IF(@="""","""",REPLACE(@,1,SEARCH(""#"",@&""#"")-1,""""))", "@", .Address), "#", MyString1))[/FONT][/COLOR]

Would you be willing to help me understand how this function is returning the characters to the right of MyString1 from the original cell please?
 
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Question Question
Finding the differences then copy and paste code to a new sheet
Replies
1
Views
624
myall_blues
myall_blues
R
  • Solved
Using "Special Characters" in VBA
Replies
4
Views
348
Alex Blakenburg
A
S
  • Solved
Creating an array of different strings for Instr to look for
2
Replies
10
Views
1K
Peter_SSs
Peter_SSs
I
  • Solved
Using InStr to Find Matches Between Columns
Replies
1
Views
939
Farscape2020
F
C
  • Solved
Help using InStr? Referencing a different sheet.
Replies
4
Views
389
Coyotex3
C

Forum statistics

Threads
1,223,893
Messages
6,175,241
Members
452,622
Latest member
Laura_PinksBTHFT

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top