Compare two lists and paste content if match is found

J

jeffsdan

New Member
Joined
Feb 13, 2014
Messages
13
I need to search the content from one list (List A, Column A) for the mention of items from another list (List B, Column A), and if any matches are found, I need to publish in Column B of List A the data from Column B of the associated matching item of List B. Can anyone help?
Tables below to help clarify what I'm asking.



List A (The list being searched)
List AColumn B (blank)
The bucket e(5) was full
The broom stood
The call came d(4)

<tbody>
</tbody>


List B (The reference list - e.g., "does list A contain any of these items")

List BColumn B
d(4)d(4) Yeah
e(5)e(5) No!
f(6)f(6) Ok

<tbody>
</tbody>


What I need the final product to look like:

List AAdded text from List B, Column B
The bucket e(5) was fulle(5) No!
The broom stood
The call came d(4)d(4) Yeah

<tbody>
</tbody>
 
Sort by date Sort by votes
Calltech,

I have had problems in the past when attempting to download an Excel file with macros, with the xlsm file extension.

Please remove all macros, and, then rename the workbooks using the xlsx file extension, and, then repost on dropbox.


And, then you can post the macros in your next reply:

When posting VBA code, please use Code Tags - like this:

[code=rich]

Paste your code here.

[/code]
 
Upvote 0

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.
Dear hiker95!

Here is the original workbook.

Run orignal.xlsx with "Combine_CompareListsV5_and_remDup" macro.

Code: 
Sub Combine_CompareListsV5_and_remDup()CompareListsV5
remDup
End Sub
Sub CompareListsV5()
' hiker95, 12/06/2015, ME759006 <- Thank You!
Dim b As Variant, i As Long
Dim a As Variant, o As Variant
Dim r As Long, lr As Long, c As Long, lc As Long, t As String
Application.ScreenUpdating = False
With Sheets("List B")
  b = .Range("A1:B" & .Range("A" & Rows.Count).End(xlUp).Row).Value
End With
With Sheets("List A")
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  lc = .Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
  a = .Range(.Cells(1, 1), .Cells(lr, lc))
  ReDim o(1 To lr, 1 To 1)
  For r = 1 To lr
    t = ""
    For c = 1 To lc Step 1
      For i = LBound(b, 1) To UBound(b, 1)
        If Not a(r, c) = vbEmpty Then
          If InStr(a(r, c), b(i, 1)) Then
            If t = "" Then
              t = b(i, 2)
            Else
              t = t & " " & b(i, 2)
            End If
          End If
        End If
      Next i
    Next c
    o(r, 1) = t
  Next r
  .Columns(1).Insert
  .Cells(1, 1).Resize(UBound(o, 1), UBound(o, 2)) = o
  .Columns(1).AutoFit
  .Activate
End With
Application.ScreenUpdating = True
End Sub


Sub remDup()
'Richard Schollar, 08/06/2009, ME407809 <- Thank You!
Dim dic As Object, cell As Range, temp As Variant
Dim i As Long
Set dic = CreateObject("scripting.dictionary")
With dic
    For Each cell In Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        .RemoveAll
        If Len(cell.Value) > 0 Then
            temp = Split(cell.Value, " ")
            For i = 0 To UBound(temp)
                If Not .Exists(temp(i)) Then .Add temp(i), temp(i)
            Next i
            cell.Value = Join(.Keys, " ")
        End If
    Next cell
    Columns("A:A").EntireColumn.AutoFit
End With
        
End Sub

And here is the changes of original.xlsx how to need to look.

Sorry again for the incorrect sharings. Next time I will have been correctly.

Thank You!
 
Upvote 0
Calltech,

When I attempted do download/open changes.xlsx I received the following message:

Excel found unreadable content in 'changes.xlsx'. Do you want to recover the content of this workbook? If you trust the source of this workbook, click Yes.
 
Upvote 0
hiker95 said:
Calltech,

When I attempted do download/open changes.xlsx I received the following message:

Excel found unreadable content in 'changes.xlsx'. Do you want to recover the content of this workbook? If you trust the source of this workbook, click Yes.
Click to expand...

I don't know, why did you get this message. I think click to Yes.
 
Upvote 0
hiker95 said:
Calltech,

I will not do that.

Please try again with your workbook on dropbox.
Click to expand...

Can you opened the original.xlsx successfully? Is this show same message? ( I added notes to the changes.xlsx for help, what I would like to change. But if you would like, I creat and upload a new workbook, which maybe not show this message again. Now I'm not computer nearby, only tomorrow. So I can do that only tomorrow. Sorry.)
 
Upvote 0
I created with Forum Tools.

Original workbook:

Before macro:

Excel 2013 64 bit
A​
B​
C​
D​
E​
1​
The bucket e(5) was d(4) fullother contentother contentother contentother content
2​
The broom stoodother contentother contentother contentThe broom f(6)
3​
The call came d(4)other contentother contentother contentother content

<tbody>
</tbody>
Sheet: LIST A

<tbody>
</tbody>

Excel 2013 64 bit
A​
B​
1​
d(4)d(4) Yeah!
2​
e(5)e(5) No!
3​
f(6)f(6) Ok

<tbody>
</tbody>
Sheet: LIST B

<tbody>
</tbody>

After macro:

Excel 2013 64 bit
A​
B​
C​
D​
E​
F​
1​
d(4) Yeah! e(5) No!The bucket e(5) was d(4) fullother contentother contentother contentother content
2​
f(6) OkThe broom stoodother contentother contentother contentThe broom f(6)
3​
d(4) Yeah!The call came d(4)other contentother contentother contentother content

<tbody>
</tbody>
Sheet: LIST A

<tbody>
</tbody>

Excel 2013 64 bit
A​
B​
1​
d(4)d(4) Yeah!
2​
e(5)e(5) No!
3​
f(6)f(6) Ok

<tbody>
</tbody>
Sheet: LIST B

<tbody>
</tbody>

Original's Macro:

Code: 
Sub Combine_CompareListsV4_and_remDup()
CompareListsV4
remDup
End Sub
Sub CompareListsV4()
' hiker95, 12/06/2015, ME759006 <- Thank You!
Dim b As Variant, i As Long
Dim a As Variant, o As Variant
Dim r As Long, lr As Long, c As Long, lc As Long, t As String
Application.ScreenUpdating = False
With Sheets("List B")
  b = .Range("A1:B" & .Range("A" & Rows.Count).End(xlUp).Row).Value
End With
With Sheets("List A")
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  lc = .Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
  a = .Range(.Cells(1, 1), .Cells(lr, lc))
  ReDim o(1 To lr, 1 To 1)
  For r = 1 To lr
    t = ""
    For c = 1 To lc Step 1
      For i = LBound(b, 1) To UBound(b, 1)
        If Not a(r, c) = vbEmpty Then
          If InStr(a(r, c), b(i, 1)) Then
            If t = "" Then
              t = b(i, 2)
            Else
              t = t & " " & b(i, 2)
            End If
          End If
        End If
      Next i
    Next c
    o(r, 1) = t
  Next r
  .Columns(1).Insert
  .Cells(1, 1).Resize(UBound(o, 1), UBound(o, 2)) = o
  .Columns(1).AutoFit
  .Activate
End With
Application.ScreenUpdating = True
End Sub

Sub remDup()
'Richard Schollar, 08/06/2009, ME407809 <- Thank You!
Dim dic As Object, cell As Range, temp As Variant
Dim i As Long
Set dic = CreateObject("scripting.dictionary")
With dic
    For Each cell In Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        .RemoveAll
        If Len(cell.Value) > 0 Then
            temp = Split(cell.Value, " ")
            For i = 0 To UBound(temp)
                If Not .Exists(temp(i)) Then .Add temp(i), temp(i)
            Next i
            cell.Value = Join(.Keys, " ")
        End If
    Next cell
    Columns("A:A").EntireColumn.AutoFit
End With
        
End Sub

Changes workbook:

Before macro:

Excel 2013 64 bit
A​
B​
C​
D​
E​
1​
The bucket e(5) was d(4) fullother contentelse10other contentother content
2​
The broom stoodother contentother contentother contentThe broom f(6)
3​
The call came d(4)other contentelse2other contentother content

<tbody>
</tbody>
Sheet: LIST A

<tbody>
</tbody>

Excel 2013 64 bit
A​
B​
C​
D​
E​
F​
1​
d(4)else1else2else3else4d(4) Yeah!
2​
else5else6else7e(5)else8e(5) No!
3​
f(6)else9else10else11else12f(6) Ok

<tbody>
</tbody>
Sheet: LIST B

<tbody>
</tbody>

After macro:

Excel 2013 64 bit
A​
B​
C​
D​
E​
F​
1​
d(4) Yeah! e(5) No! f(6) OkThe bucket e(5) was d(4) fullother contentelse10other contentother content
2​
f(6) OkThe broom stoodother contentother contentother contentThe broom f(6)
3​
d(4) Yeah! d(4) Yeah!The call came d(4)other contentelse2other contentother content

<tbody>
</tbody>
Sheet: LIST A

<tbody>
</tbody>

Excel 2013 64 bit
A​
B​
C​
D​
E​
F​
1​
d(4)else1else2else3else4d(4) Yeah!
2​
else5else6else7e(5)else8e(5) No!
3​
f(6)else9else10else11else12f(6) Ok

<tbody>
</tbody>
Sheet: LIST B

<tbody>
</tbody>

The only changes in new macro, that the LIST B - Column A supplemented with +4 columns.

Thank You for your help.
 
Last edited:
Upvote 0
Of course in the end the duplication disappears in LIST A - Column A with the part of "remDup" macro.
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Solved
Create distinct list with criteria
Replies
3
Views
142
Fluff
Fluff
E
  • Question
Generate lists based on Column information
Replies
6
Views
173
JerrExcel
JerrExcel
M
  • Solved
Display textbox from listbox - getting 381 error
Replies
4
Views
254
maiatanaka
M
A
  • Solved
Total all in validation list
Replies
3
Views
36
Fluff
Fluff
P
  • Solved
Excel VBA, Vlookup to another sheet in same work book
Replies
6
Views
235
StephenCrump
S

Forum statistics

Threads
1,215,510
Messages
6,125,228
Members
449,216
Latest member
biglake87

Share this page

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
Back
Top