# Extract matching words between 2 cells

#### excellahuntress

##### New Member
How can I extract matching word and numbers between cells in the same column? The current cell will only need to compare with the cell below it and not have to search the entire column.

Example:
A
1. 100 Red apples
2. 100 big red apples
3. A pack of 100 red apples
4. 300 yellow bananas
5. A batch of yellow bananas

So comparing A1 and A2 should result "100 red apples"
Comparing A2 and A3 should show "100 red apples"
Comparing A3 and A4 should put out nothing since there were no matches.
Comparing A4 and A5 should show "yellow bananas"

### Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.

#### hnsd24_CN

##### Board Regular
I used custom functions
union.xlsm
AB
1100 Red apples100 Red apples
2100 big red apples100 red apples
3A pack of 100 red apples
4300 yellow bananasyellow bananas
5A batch of yellow bananasyellow bananas
6
7
8
Sheet2
Cell Formulas
RangeFormula
B1:B7B1=compare()

Put the code into module
VBA Code:
``````Public Function compare()
Dim txt1 As String, txt2 As String, txt As String
Dim i As Integer, r As Integer, s As Integer
Dim reg As Object, mh1 As Object, mh2 As Object
Dim rs As Integer
Set reg = CreateObject("vbscript.regexp")
rs = ActiveWorkbook.Application.ThisCell.Row
If Cells(rs, 1) <> "" Then
txt1 = Cells(rs, 1)
If Cells(rs + 1, 1) <> "" Then
txt2 = Cells(rs + 1, 1)
Else
txt2 = Cells(rs - 1, 1)
End If
reg.Pattern = "\w+"
reg.Global = True
Set mh1 = reg.Execute(txt1)
Set mh2 = reg.Execute(txt2)
For i = 0 To mh1.Count - 1
r = 0
Do Until r = mh2.Count
If LCase(mh1(i)) = LCase(mh2(r)) Then
txt = txt & " " & mh1(i)
s = s + 1
Exit Do
End If
r = r + 1
Loop
Next
End If
If s > 0 Then
compare = Mid(txt, 2)
Else
compare = ""
End If
End Function``````

#### hnsd24_CN

##### Board Regular
Or
union.xlsm
AB
1100 Red apples100 Red apples
2100 big red apples100 red apples
3A pack of 100 red apples
4300 yellow bananasyellow bananas
5A batch of yellow bananas
6
7
Sheet2
Cell Formulas
RangeFormula
B1:B7B1=compare(A1,A2)

VBA Code:
``````Public Function compare(rng1 As Range, rng2 As Range)
Dim txt As String
Dim i As Integer, r As Integer, s As Integer
Dim reg As Object, mh1 As Object, mh2 As Object
Dim rs As Integer
Set reg = CreateObject("vbscript.regexp")
If rng1.Value <> "" And rng2.Value <> "" Then
reg.Pattern = "\w+"
reg.Global = True
Set mh1 = reg.Execute(rng1.Value)
Set mh2 = reg.Execute(rng2.Value)
For i = 0 To mh1.Count - 1
r = 0
Do Until r = mh2.Count
If LCase(mh1(i)) = LCase(mh2(r)) Then
txt = txt & " " & mh1(i)
s = s + 1
Exit Do
End If
r = r + 1
Loop
Next
End If
If s > 0 Then
compare = Mid(txt, 2)
Else
compare = ""
End If
End Function``````

#### excellahuntress

##### New Member
I used custom functions
union.xlsm
AB
1100 Red apples100 Red apples
2100 big red apples100 red apples
3A pack of 100 red apples
4300 yellow bananasyellow bananas
5A batch of yellow bananasyellow bananas
6
7
8
Sheet2
Cell Formulas
RangeFormula
B1:B7B1=compare()

Put the code into module
VBA Code:
``````Public Function compare()
Dim txt1 As String, txt2 As String, txt As String
Dim i As Integer, r As Integer, s As Integer
Dim reg As Object, mh1 As Object, mh2 As Object
Dim rs As Integer
Set reg = CreateObject("vbscript.regexp")
rs = ActiveWorkbook.Application.ThisCell.Row
If Cells(rs, 1) <> "" Then
txt1 = Cells(rs, 1)
If Cells(rs + 1, 1) <> "" Then
txt2 = Cells(rs + 1, 1)
Else
txt2 = Cells(rs - 1, 1)
End If
reg.Pattern = "\w+"
reg.Global = True
Set mh1 = reg.Execute(txt1)
Set mh2 = reg.Execute(txt2)
For i = 0 To mh1.Count - 1
r = 0
Do Until r = mh2.Count
If LCase(mh1(i)) = LCase(mh2(r)) Then
txt = txt & " " & mh1(i)
s = s + 1
Exit Do
End If
r = r + 1
Loop
Next
End If
If s > 0 Then
compare = Mid(txt, 2)
Else
compare = ""
End If
End Function``````
Yes this is it! Thank you so so so very much!

Replies
8
Views
66
Replies
2
Views
207
Replies
9
Views
193
Replies
5
Views
236
Replies
9
Views
232

1,147,482
Messages
5,741,409
Members
423,658
Latest member

### 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.

### Which adblocker are you using?

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

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