Instring Search to Return whole Line

[christian2016]

Hi There,

I have all text in a cell example
Cell A1
Today is hot
Last week was cold
Today's weather is 18
Next week is 20

I need a VBA code that searches the cell via instring search for example searches "Today's weather" and will return the whole line "Today's weather is 18" which then i will store this value in another cell.

Any help is greatly appreciated

Thanks

 

[Peter_SSs]

1. Will the string being searched for (Today's weather) always be at the start of one of the lines of text in the cell or might you have to search for, say, "week was"?
2. Do you really need vba as this should be achievable with a standard worksheet formula?
3. What should happen if the text being searched for was "Today", given that starts two of the lines in the cell?

 

[christian2016]

1. No wont be at the start can be anywhere in the string
2. Yes for the purpose i need it, its better to be in a VBA code
3. The string will be unique and only should find one match.

Thanks

 

[Peter_SSs]

Something like this then?

Sub ExtractLine()
  Dim a As Variant, b As Variant
  Dim i As Long

  a = Range("A1", Range("B" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 1)
  On Error Resume Next
  For i = 1 To UBound(a)
    b(i, 1) = Trim(Filter(Split(Replace(" " & a(i, 1) & " ", Chr(10), " | "), "|"), " " & a(i, 2) & " ")(0))
  Next i
  On Error GoTo 0
  With Range("C1").Resize(UBound(b))
    .Value = b
    .Columns.AutoFit
  End With
End Sub

Book1
	A	B	C
1	Today is hot Last week was cold Today's weather is 18 Next week is 20	weather	Today's weather is 18
2	Today is hot Last week was cold Today's weather is 18 Next week is 21	Today is	Today is hot
3	Today is hot Last week was cold Today's weather is 18 Next week is 22	cold	Last week was cold
4	Today is hot Last week was cold Today's weather is 18 Next week is 23	Next	Next week is 23
5	Today is hot Last week was cold Today's weather is 18 Next week is 24	Monday
Extract Line from cell

The code is currently case-sensitive. If you don't want that then change this line

b(i, 1) = Trim(Filter(Split(Replace(" " & a(i, 1) & " ", Chr(10), " | "), "|"), " " & a(i, 2) & " ", 1, 1)(0))

 

[Rick Rothstein]

Something like this then?

Sub ExtractLine()
  Dim a As Variant, b As Variant
  Dim i As Long

  a = Range("A1", Range("B" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 1)
  On Error Resume Next
  For i = 1 To UBound(a)
    b(i, 1) = Trim(Filter(Split(Replace(" " & a(i, 1) & " ", Chr(10), " | "), "|"), " " & a(i, 2) & " ")(0))
  Next i
  On Error GoTo 0
  With Range("C1").Resize(UBound(b))
    .Value = b
    .Columns.AutoFit
  End With
End Sub

The code is currently case-sensitive. If you don't want that then change this line

b(i, 1) = Trim(Filter(Split(Replace(" " & a(i, 1) & " ", Chr(10), " | "), "|"), " " & a(i, 2) & " ", 1, 1)(0))

As written, you code requires the word (or words) you are searching for be delimited from the rest of the text by spaces (or be located on either end of the text. If the word (or words) should be next to a non-alphanumeric character (such as a period, comma, quote mark, parenthesis, etc.) it will not find the word (or words). I am pretty sure the modifications I made to your code (assuming the search is not case sensitive... remove the blue highlighted text if a case sensitive search is required), shown in red, will make it work no matter what non-alphanumeric characters surround the word (or words)...

[table="width: 500"]
[tr]
	[td]Sub ExtractLine()
  Dim a As Variant, b As Variant[B][COLOR="#FF0000"], Arr As Variant[/COLOR][/B]
  Dim i As Long[B][COLOR="#FF0000"], Txt As String[/COLOR][/B]

  a = Range("A1", Range("B" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 1)
  On Error Resume Next
  For i = 1 To UBound(a)
[B][COLOR="#FF0000"]    Txt = ""
    Txt = Filter(Split(a(i, 1), vbLf), a(i, 2)[B][COLOR="#0000FF"], , vbTextCompare[/COLOR][/B])(0)
    Arr = Split(" " & Txt & " ", a(i, 2))
    If Arr(0) Like "*[!A-Za-z0-9]" And Arr(1) Like "[!A-Za-z0-9]*" Then b(i, 1) = Txt
[/COLOR][/B]  Next i
  On Error GoTo 0
  With Range("C1").Resize(UBound(b))
    .Value = b
    .Columns.AutoFit
  End With
End Sub[/td]
[/tr]
[/table]

Note: I know it looks strange, but the Txt = "" line of code is required... without it, the On Error Resume Next statement will make the Txt variable retain its value from the last iteration of the loop when the Filter function fails.

 

[Rick Rothstein]

[table="width: 500"]
[tr]
	[td]Sub ExtractLine()
  Dim a As Variant, b As Variant[B][COLOR="#FF0000"], Arr As Variant[/COLOR][/B]
  Dim i As Long[B][COLOR="#FF0000"], Txt As String[/COLOR][/B]

  a = Range("A1", Range("B" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 1)
  On Error Resume Next
  For i = 1 To UBound(a)
[B][COLOR="#FF0000"]    Txt = ""
    Txt = Filter(Split(a(i, 1), vbLf), a(i, 2)[B][COLOR="#0000FF"][B][COLOR="#0000FF"], , vbTextCompare[/COLOR][/B][/COLOR][/B])(0)
    Arr = Split(" " & Txt & " ", a(i, 2))
    If Arr(0) Like "*[!A-Za-z0-9]" And Arr(1) Like "[!A-Za-z0-9]*" Then b(i, 1) = Txt
[/COLOR][/B]  Next i
  On Error GoTo 0
  With Range("C1").Resize(UBound(b))
    .Value = b
    .Columns.AutoFit
  End With
End Sub[/td]
[/tr]
[/table]

Note: I know it looks strange, but the Txt = "" line of code is required... without it, the On Error Resume Next statement will make the Txt variable retain its value from the last iteration of the loop when the Filter function fails.

Actually, we can simplify the modification slightly (the changes to your original code are still shown in red)...

[table="width: 500"]
[tr]
	[td]Sub ExtractLine21()
  Dim a As Variant, b As Variant
  Dim i As Long[B][COLOR="#FF0000"], Txt As String[/COLOR][/B]

  a = Range("A1", Range("B" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 1)
  On Error Resume Next
  For i = 1 To UBound(a)
[B][COLOR="#FF0000"]    Txt = ""
    Txt = " " & Filter(Split(a(i, 1), vbLf), a(i, 2)[B][COLOR="#0000FF"], , vbTextCompare[/COLOR][/B])(0) & " "
    If Txt Like "*[!A-Za-z0-9]" & a(i, 2) & "[!A-Za-z0-9]*" Then b(i, 1) = Txt
[/COLOR][/B]  Next i
  On Error GoTo 0
  With Range("C1").Resize(UBound(b))
    .Value = b
    .Columns.AutoFit
  End With
End Sub[/td]
[/tr]
[/table]

 

[Peter_SSs]

Rick, much (all?) of what you say is correct, but on re-reading the thread, I had already introduced things that were not asked for (concept of 'words') and you have introduced even more (checking punctuation).
It may be that some or all of those things will end up being needed but to answer the question actually asked, perhaps all that is needed is this much-reduced line substituted into my original code.

b(i, 1) = Filter(Split(a(i, 1), Chr(10)), a(i, 2), 1, 1)(0)

.. or indeed this macro instead. I've assumed each line in the cells will be <= 200 characters.

Sub ExtractLine_v2()
  With Range("C1:C" & Range("A" & Rows.Count).End(xlUp).Row)
    .Value = Evaluate(Replace(Replace("iferror(trim(mid(substitute(char(10)&#,char(10),rept("" "",200)),search(^,substitute(char(10)&#,char(10),rept("" "",200)))-200,400)),"""")", "#", .Offset(, -2).Address), "^", .Offset(, -1).Address))
    .Columns.AutoFit
  End With
End Sub

BTW Rick, your latest code has reintroduced case-sensitivity.

 

[Rick Rothstein]

...perhaps all that is needed is this much-reduced line substituted into my original code.

b(i, 1) = Filter(Split(a(i, 1), Chr(10)), a(i, 2), 1, 1)(0)

I actually posted the line of code and then went back and deleted it when I realized your code was attempting to protect against finding the word (or words) embedded in a larger word (or phrase), although I had written it this way as I try to use built-in constants whenever possible as I feel they make code a little more self-documenting...

b(i, 1) = Filter(Split(a(i, 1), vbLf), a(i, 2), , vbTextCompare)(0)

BTW Rick, your latest code has reintroduced case-sensitivity.

The latest code I posted used a case-insensitive search.

 

[Peter_SSs]

The latest code I posted used a case-insensitive search.

But the following 'Like' line is not. With the sample data from post 4, try it with B1= "Weather"

 

[Rick Rothstein]

But the following 'Like' line is not. With the sample data from post 4, try it with B1= "Weather"

I was looking in the wrong place for the problem.

Okay, I guess the code I posted in Message #6 should look like this then...

Sub ExtractLine21()
  Dim a As Variant, b As Variant
  Dim i As Long[B][COLOR="#FF0000"], Txt As String[/COLOR][/B]

  a = Range("A1", Range("B" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 1)
  On Error Resume Next
  For i = 1 To UBound(a)
[B][COLOR="#FF0000"]    Txt = ""
    Txt = " " & Filter(Split(a(i, 1), vbLf), a(i, 2), , vbTextCompare)(0) & " "
    If UCase(Txt) Like "*[!A-Z0-9]" & UCase(a(i, 2)) & "[!A-Z0-9]*" Then b(i, 1) = Txt
[/COLOR][/B]  Next i
  On Error GoTo 0
  With Range("C1").Resize(UBound(b))
    .Value = b
    .Columns.AutoFit
  End With
End Sub