Extract matching words between 2 cells

excellahuntress

New Member
Joined
Oct 31, 2020
Messages
7
Office Version
  1. 365
Platform
  1. Windows
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

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest

hnsd24_CN

Board Regular
Joined
Oct 13, 2020
Messages
78
Office Version
  1. 2016
Platform
  1. Windows
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
Joined
Oct 13, 2020
Messages
78
Office Version
  1. 2016
Platform
  1. Windows
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
Joined
Oct 31, 2020
Messages
7
Office Version
  1. 365
Platform
  1. Windows
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!
 

Forum statistics

Threads
1,144,246
Messages
5,723,215
Members
422,485
Latest member
Tameima

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
Top