Finding text in one column that compares to another

[Guest]

In a spreadsheet I have one column with single item names and a second column
with strings of data. I am trying to set up a routine that will search the
column with strings for the names found in the first one. The result needed
is to place the name in a third column adjacent to the one with the string
that contains the name. I have come up with this:

If InStr(Range("B2"), ActiveCell) Then Range("C2") = ActiveCell
If InStr(Range("B3"), ActiveCell) Then Range("C2") = ActiveCell
etc.

This works if I use "Offset" and type a separate line of code for each row
of data but this is rather inconvenient since there are over 1000 rows.

Is there a better way to accomplish this?

Thanks for any help anyone may offer.

 

[Tom Ogilvy]

Sub bbb()
Dim rngA As Range, rngB As Range
Dim rng As Range, cell As Range
Dim res As Variant
With Worksheets("Sheet1")
Set rngA = .Range(.Cells(2, 1), .Cells(2, 1).End(xlDown))
Set rngB = .Range(.Cells(2, 2), .Cells(2, 2).End(xlDown))
End With
For Each cell In rngA
res = Application.Match("*" & cell.Value & "*", rngB, 0)
If Not IsError(res) Then
Set rng = rngB(res)
rng.Offset(0, 1).Value = cell
End If
Next

End Sub

worked for me. It assumes the lists start in A2 and B2. If in A1 and B1,
change

With Worksheets("Sheet1")
Set rngA = .Range(.Cells(1, 1), .Cells(1, 1).End(xlDown))
Set rngB = .Range(.Cells(1, 2), .Cells(1, 2).End(xlDown))
End With

 

[Guest]

Use Test2 if there are potentially blanks in the range else use Test:

Sub Test()
Dim r As Range, c As Range
Set r = Range(ActiveCell, ActiveCell.End(xlDown))
Application.ScreenUpdating = False
For Each c In r.Cells
If InStr(c.Value, ActiveCell.Value) > 0 Then _
c(1, 2).Value = ActiveCell.Value
Next
Application.ScreenUpdating = True
End Sub

Sub Test2()
Dim r As Range, c As Range
Dim col As Long
col = ActiveCell.Column
Set r = Range(ActiveCell, Cells(Rows.Count, col).End(xlUp))
Application.ScreenUpdating = False
For Each c In r.Cells
If InStr(c.Value, ActiveCell.Value) > 0 Then _
c(1, 2).Value = ActiveCell.Value
Next
Application.ScreenUpdating = True
End Sub

Regards,
Greg

 

[Guest]

I see that Tom had a different take on your request that I did. On second
read, his seems far more likely.

I took a cue from your code and assumed you simply wanted to paste the
active cell contents to the third column where a match was found in the
second column and where the active cell was the first cell in the second
column and therefore was a constant.

There seems to be a potential that the cell contents of the first column,
since they only need to form part of the contents of the cells in the second
column, can gererate overlapping matches, and thus a potential for the
supplanting of results in the third column.

Regards,
Greg

 

[Tom Ogilvy]

To the OP. This code will overwrite some of your data ( if I understand
your the situation) and the activecell is in column A when you run it.

Test it on a copy of your data. (always good advice)

 

[Guest]

This works quite well. I found one anomaly where two rows have similar
names, such as "surnames Jackson" and "Jackson County". "Jackson" appeared
beside both instances although it only belongs beside one. I think I can
work out some conditions to add to the mix. If not, this is a minor thing
which can be dealt with.

The important thing is that this works perfectly as designed. Thank you
very much.

 

[Tom Ogilvy]

Greg raises a good point that the names in column A would need to be unique.

Also, as written, Jackson in column A would match Jacksonville as well as
Jackson County.

Some could be overcome with

res = Application.Match("*" & cell.Value & " *", rngB, 0)

add a space before the second asterisk and/or before the first asterisk.
However, that would fail on Jackson. or Jackson as the first character in
the string. Those wouldn't fix Jackson County, however. I think that is
the 10 percent that would have to be double checked.

Also, if two names are matched in the same cell, only one would appear to
the right.

 

[Guest]

I had stated that I found duplicate matches but found that not to be true.
In fact, I have learned that I need to find duplicate matches, so that the
cell showing the results will be filled in for each occurence of the match.
I have tried making changes to the routine but with no success.

How can I change the routine to find each occurence instead of the first it
comes across?

Thanks,

Jim

 

[Guest]

This will fiind duplicates and will not supplant the contents in the third
row. For example, for the following scenario:

A4 = "Jackson"
A10 = "County"
A15 = "Frank"
A17 = "Hen"
A20 = "Arch"

All other cells in column A populated with text not found in column B.

B2 = "Franklin and Henderson Architechs"
B6 = "Jacksonville County"
B9 = "Mike Jackson"

Result:

C2 = "Frank" and "Hen" and "Arch" in the same cell
C6 = "Jackson" and "County" in the same cell
C9 = "Jackson"

If the text of more than one cell in column A is found in the same cell in
column B then these multiple hits will be displayed in the adjacent cell in
column C in separate lines (i.e. wrapped). So the contents of cells in column
C are not supplanted. Also, if the contents of a single cell in column A is
found in more than one cell in column B then these will be displayed in the
adjacent cells in column C.

Run on a copy of your data as Tom mentioned. Hope it's what you were looking
for.

Regards,
Greg

Sub Test()
Dim r As Range, r2 As Range
Dim c As Range, c2 As Range, c3 As Range
Dim wks As Worksheet

Application.ScreenUpdating = False
Set wks = Sheets("Sheet1")
With wks
Set r = .Range(.Cells(2, 1), _
.Cells(2, 1).End(xlDown))
Set r2 = .Range(.Cells(2, 2), _
.Cells(2, 2).End(xlDown))
End With
For Each c In r.Cells
For Each c2 In r2.Cells
If c2 Like "*" & c & "*" Then
Set c3 = c2(1, 2)
If Len(c3) = 0 Then c3 = c _
Else c3 = c3 & Chr(10) & c
End If
Next c2
Next c
Application.ScreenUpdating = True
End Sub

 

[Ren]

Hi Tom,

i have 3 sheets,
main data is in sheet1,(items and required quantity)
i have to find the items(random data) in sheet2 first,if i find the matching
check the quntity against the required qunatity of sheet1.
supply the quantity(based on whether it's in store1 or store2) and keep the
balance and the item number in sheet2.
if there is no matching then goto sheet2 and search for the item.and get the
matching qunatity.
i have around 150 to 200 rows,and keeps changing everyday.
pl read my post find the matching
the code is like this

Sub allocation()


With Sheets("polist")
sh1lastrow = .Cells(Rows.Count, "F").End(xlUp).Row
Set sh1range = .Range("F2:F" & sh1lastrow)
End With
With Sheets("slrs")
sh2lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
Set sh2range = .Range("A2:A" & sh2lastrow)
End With
With Sheets("FAB")
Sh3LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Set Sh3Range = .Range("A2:A" & Sh3LastRow)
End With

For Each sh1cell In sh1range
Set c = sh2range.Find( _
what:=sh1cell, LookIn:=xlValues)

If c Is Nothing Then

sh1cell.Interior.ColorIndex = 4
sh1cell.Offset(0, 1).Interior.ColorIndex = 4
Else

If sh1cell.Offset(0, 2) < c.Offset(0, 3) Then
sh1cell.Offset(0, 3).Value = sh1cell.Offset(0, 2)
c.Offset(0, 6).Value = sh1cell.Offset(0, 2)
c.Offset(0, 4).FormulaR1C1 = "=RC[-1]-RC[2]"
c.Offset(0, 5).Value = sh1cell.Offset(0, -3)
Else
If sh1cell.Offset(0, 2) > c.Offset(0, 3) Then
sh1cell.Offset(0, 3).Value = c.Offset(0, 3)
c.Offset(0, 6).Value = sh1cell.Offset(0, 3)
Sheets("slrs").Range("G:G").NumberFormat = "0;[Red]0"
c.Offset(0, 4).FormulaR1C1 = "=RC[-1]-RC[2]"
c.Offset(0, 5).Value = sh1cell.Offset(0, -3)
Sheets("slrs").Range("F:F").NumberFormat = "0;[Red]0"
Range("F:F").ColumnWidth = 18

End If
End If
End If
Next sh1cell
End Sub

pl guide me
Ren