Extract matching words between 2 cells

[excellahuntress]

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"

 

[hnsd24_CN]

I used custom functions

union.xlsm
	A	B
1	100 Red apples	100 Red apples
2	100 big red apples	100 red apples
3	A pack of 100 red apples
4	300 yellow bananas	yellow bananas
5	A batch of yellow bananas	yellow bananas
6
7
8
Sheet2

Cell Formulas
Range	Formula
B1:B7	B1	=compare()

Put the code into module

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]

Or

union.xlsm
	A	B
1	100 Red apples	100 Red apples
2	100 big red apples	100 red apples
3	A pack of 100 red apples
4	300 yellow bananas	yellow bananas
5	A batch of yellow bananas
6
7
Sheet2

Cell Formulas
Range	Formula
B1:B7	B1	=compare(A1,A2)

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]

I used custom functions

union.xlsm
	A	B
1	100 Red apples	100 Red apples
2	100 big red apples	100 red apples
3	A pack of 100 red apples
4	300 yellow bananas	yellow bananas
5	A batch of yellow bananas	yellow bananas
6
7
8
Sheet2

Cell Formulas
Range	Formula
B1:B7	B1	=compare()

Put the code into module

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!

 

[yysms06256]

What if it needs to loop over the whole column ? Hows the VBA look like