Search specific text and past in specified cell

[acc16]

Hi,

Any help is appreciated on this query.

I have a sentence in column C (Sheet1) and I need to search a specific text which is placed in Sheet2 Column A1 till A100. I am trying to check if Sheet1 Column C has the text from Sheet2 Column A and place that text in Sheet1 Column E.

For example.
Sheet1-Column C2 = "Error in P0001 as on specific date"
Sheet1-Column C3 = "Not able to find 0003 in field SD"
Sheet1-Column C4 = "Not alligned to P0003 for the record".

Sheet2-Column A1 = "0000"
Sheet2-Column A2 = "0001"
Sheet2-Column A3 = "0002"
Sheet2-Column A4 = "0003"

My requirement is to read Sheet2 A:A and then find/search if that exists in Sheet1 Column C:C and if it exists then paste that value ("0000"/"0003") in corrosponding column "E".

 

[machopicho]

Try:

Sub test()
Dim IsNumero As Boolean
Dim i, r, rw As Integer

Application.Volatile True
For rw = 1 To Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Row
For i = 1 To Len(Cells(rw, 3))
If Mid(Cells(rw, 3), i, 1) <= "9" And Mid(Cells(rw, 3), i, 1) >= "0" Then
C = C + Mid(Cells(rw, 3), i, 1)
IsNumero = True
Else
IsNumero = False
End If
Next i
Sheets("Sheet1").Cells(rw, 5) = C
C = 0
For r = 1 To Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
If Sheets("Sheet2").Cells(r, 1) = Sheets("Sheet1").Cells(rw, 5) Then
Sheets("Sheet1").Cells(rw, 5).Interior.ColorIndex = 20
End If
Next r, rw
For Each cll In Sheets("Sheet1").Range("E1:E" & rw)
If cll.Interior.ColorIndex <> 20 Then
cll.Clear
End If
cll.Interior.ColorIndex = none
Next
End Sub

 

[hiker95]

acc16,


Sample data:

Excel Workbook
	A
1	0000
2	0001
3	0002
4	0003
5
Sheet2

Excel Workbook
	C	D	E
2	Error in P0001 as on specific date
3	Not able to find 0003 in field SD
4	Not alligned to P0003 for the record
5
Sheet1

After the macro in worksheet Sheet1:

Excel Workbook
	C	D	E
2	Error in P0001 as on specific date		0001
3	Not able to find 0003 in field SD		0003
4	Not alligned to P0003 for the record		0003
5
Sheet1

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code, by highlighting the code and pressing the keys CTRL + C
2. Open your workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel, open the workbook, and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Option Explicit
Sub SearchForString()
' hiker95, 08/05/2011
' http://www.mrexcel.com/forum/showthread.php?t=569493
Dim w1 As Worksheet, w2 As Worksheet
Dim c As Range, firstaddress As String
Dim s(), t As Long
Application.ScreenUpdating = False
Set w1 = Worksheets("Sheet1")
Set w2 = Worksheets("Sheet2")
s = w2.Range("A1:A100")
For t = LBound(s) To UBound(s)
  If s(t, 1) <> "" Then
    firstaddress = ""
    With w1.Columns(3)
      Set c = .Find("*" & s(t, 1) & "*", LookIn:=xlValues, LookAt:=xlWhole)
      If Not c Is Nothing Then
        firstaddress = c.Address
        Do
          With c.Offset(, 2)
            .NumberFormat = "@"
            .Value = s(t, 1)
          End With
          Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstaddress
      End If
    End With
  End If
Next t
w1.Activate
Application.ScreenUpdating = True
End Sub

Then run the SearchForString macro.


Can the strings in Sheet1, column C, contain more that one of the strings in Sheet2? If so, I can adjust the macro.

 

[acc16]

Hi hiker95,

Thanks a lot.

The code works perfectly for single string. Since thr r chances of repeated string in the text. Could you please let me know how to get that as well?

 

[hiker95]

acc16,

Can I see some strings in Sheet1 containing multiple codes from Sheet2, and what would column E look like (format/style)?

 

[acc16]

Hi hiker95,

The string can be like "Error in P0007 as on specific date due to which it missed PA0008 and 0009".

 

[hiker95]

acc16,

If this is in cell C7:
Error in P0007 as on specific date due to which it missed PA0008 and 0009

What would cell E7 look like (format/stype/string seperator)?

And, what would be the additional codes in Sheet2?

 

[acc16]

Hi hiker95,

The output required is a pipe-delimited string.

Ex. "0007|0008|0009"

 

[hiker95]

acc16,


Sample data:

Excel Workbook
	A
1	0000
2	0001
3	0002
4	0003
5	0004
6	0005
7	0006
8	0007
9	0008
10	0009
11	0010
12	0011
13	0012
14	0013
15	0014
16
Sheet2

Excel Workbook
	C	D	E
2	Error in P0001 as on specific date
3	Not able to find 0003 in field SD
4	Not alligned to P0003 for the record
5	Error in P0007 as on specific date due to which it missed PA0008 and 0009
6	Error in P0007 as on specific date
7	Error in P0007 as on specific date due to which it missed PA0008
8	Error in P0007 as on specific date due to which it missed PA0008 and 0005
9
Sheet1

After the macro in worksheet Sheet1:

Excel Workbook
	C	D	E
2	Error in P0001 as on specific date		0001
3	Not able to find 0003 in field SD		0003
4	Not alligned to P0003 for the record		0003
5	Error in P0007 as on specific date due to which it missed PA0008 and 0009		0007|0008|0009
6	Error in P0007 as on specific date		0007
7	Error in P0007 as on specific date due to which it missed PA0008		0007|0008
8	Error in P0007 as on specific date due to which it missed PA0008 and 0005		0005|0007|0008
9
Sheet1

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Option Explicit
Sub SearchForStringV2()
' hiker95, 08/06/2011
' http://www.mrexcel.com/forum/showthread.php?t=569493
Dim w1 As Worksheet, w2 As Worksheet
Dim d As Range, c As Range, firstaddress As String
Dim s(), t As Long, H As String
Application.ScreenUpdating = False
Set w1 = Worksheets("Sheet1")
Set w2 = Worksheets("Sheet2")
s = w2.Range("A1:A100")
For Each d In w1.Range("C2", w1.Range("C" & Rows.Count).End(xlUp))
  H = ""
  For t = LBound(s) To UBound(s)
    If s(t, 1) <> "" Then
      firstaddress = ""
      With d
        Set c = .Find("*" & s(t, 1) & "*", LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
          firstaddress = c.Address
          Do
            H = H + s(t, 1) & "|"
            Set c = .FindNext(c)
          Loop While Not c Is Nothing And c.Address <> firstaddress
        End If
      End With
    End If
  Next t
  If H <> "" Then
    If Right(H, 1) = "|" Then
      H = Left(H, Len(H) - 1)
    End If
    With d.Offset(, 2)
      .NumberFormat = "@"
      .Value = H
    End With
  End If
Next d
w1.Columns(5).AutoFit
w1.Activate
Application.ScreenUpdating = True
End Sub

Then run the SearchForStringV2 macro.

 

[hiker95]

acc16,


Same screenshots as my last reply, but the following macro should run faster.


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Option Explicit
Sub SearchForStringV3()
' hiker95, 08/06/2011
' http://www.mrexcel.com/forum/showthread.php?t=569493
Dim w1 As Worksheet, w2 As Worksheet
Dim c As Range, firstaddress As String
Dim s(), t As Long
Application.ScreenUpdating = False
Set w1 = Worksheets("Sheet1")
Set w2 = Worksheets("Sheet2")
s = w2.Range("A1:A100")
For t = LBound(s) To UBound(s)
  If s(t, 1) <> "" Then
    firstaddress = ""
    With w1.Columns(3)
      Set c = .Find("*" & s(t, 1) & "*", LookIn:=xlValues, LookAt:=xlWhole)
      If Not c Is Nothing Then
        firstaddress = c.Address
        Do
          If c.Offset(, 2) = "" Then
            With c.Offset(, 2)
              .NumberFormat = "@"
              .Value = s(t, 1)
            End With
          Else
            With c.Offset(, 2)
              .NumberFormat = "@"
              .Value = .Value & "|" & s(t, 1)
            End With
          End If
          Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstaddress
      End If
    End With
  End If
Next t
w1.Columns(5).AutoFit
w1.Activate
Application.ScreenUpdating = True
End Sub

Then run the SearchForStringV3 macro.