You are here:

Excel/Match strings and copy to adjacent cell separated by comma

Advertisement


Question
QUESTION: Hi Damon,

Thanks for the previous help. I have a problem here. I have 2 sheest  - sheet 1 has column B is filled will sentences and sheet 2 column A has words. i want to match the words from sheet 2 column A and Sheet 1 column B and want the result in sheet 1 column c for all matching words separated by comma. I have this code below which does copy first matching word but not all matches.

Sub CopyBasedonSheet1()Dim i As Long
   Dim j As Long, fn As Range, sh As Worksheet, fAdr As String
   Set sh = Sheets("Sheet1")
   Sheet2LastRow = Worksheets("sheet2").Range("A" & Rows.Count).End(xlUp).Row
   For i = 1 To Sheet2LastRow
       Set fn = sh.Range("B:B").Find(Sheets("Sheet2").Cells(i, 1).Value, , xlValues, xlPart)
       If Not fn Is Nothing Then
         fAdr = fn.Address
         Do
         fn.Offset(0, 1) = Sheets("Sheet2").Cells(i, 1).Value
         Set fn = sh.Range("B:B").FindNext(fn)
         Loop While fAdr <> fn.Address
       End If
   Next
End Sub


Could you please answer this. Thanks in advance. Hope to get your answer soon.

Regards

ANSWER: Hi again Sofia,

I believe this modification of your code does what you want:

_________________________________

Sub CopyBasedonSheet2()
  Dim i As Long
  Dim j As Long, fn As Range, sh1 As Worksheet, sh2 As Worksheet, fAdr As String
  Dim Sheet2LastRow    As Long
  Set sh1 = Sheets("Sheet1")   'Sheet with sentences to be searched in col B
  Set sh2 = Sheets("Sheet2")   'Sheet with keyword list in column A
  Sheet2LastRow = sh2.Cells(Rows.Count, "A").End(xlUp).Row
  For i = 1 To Sheet2LastRow
      Set fn = sh1.Range("B:B").Find(sh2.Cells(i, "A").Text, , xlValues, xlPart)
      If Not fn Is Nothing Then
        fAdr = fn.Address
        Do
         With fn.Offset(0, 1)
         If IsEmpty(.Cells) Then
         .Value = sh2.Cells(i, "A").Text
         Else
         .Value = .Text & ", " & sh2.Cells(i, "A").Text
         End If
         Set fn = sh1.Range("B:B").FindNext(fn)
         End With
        Loop While fn.Address <> fAdr
      End If
  Next
End Sub
__________________________________________

I hope you find this helpful.

Damon

---------- FOLLOW-UP ----------

QUESTION: Thanks so much Damon it is working perfectly. Just one more thing is it possible to modify the code in such a way that it search 2 columns in different sheet (column A from sheet 2 and column A from Sheet 3 with column B in sheet 1) and copy only unique words separated by comma in sheet 1 column C.

Regards

ANSWER: Hi again Sofia,

Give this a try:

________________________________

Sub CopyBasedonSheet3()
  Dim i       As Long
  Dim j       As Long, fn As Range
  Dim sh1     As Worksheet, sh2 As Worksheet, sh3 As Worksheet
  Dim fAdr    As String
  Dim Sheet2LastRow    As Long
  Dim Sheet3LastRow    As Long
  
  Set sh1 = Sheets("Sheet1")   'Sheet with sentences to be searched in col B
  Set sh2 = Sheets("Sheet2")   'Sheet with keyword list in column A
  Set sh3 = Sheets("Sheet3")   'Another sheet with keyword list in column A
  
  Sheet2LastRow = sh2.Cells(Rows.Count, "A").End(xlUp).Row
  Sheet3LastRow = sh3.Cells(Rows.Count, "A").End(xlUp).Row
  
  'Do word list on Sheet2
  
  For i = 1 To Sheet2LastRow
      Set fn = sh1.Range("B:B").Find(sh2.Cells(i, "A").Text, , xlValues, xlPart)
      If Not fn Is Nothing Then
        fAdr = fn.Address
        Do
         With fn.Offset(0, 1)
         If IsEmpty(.Cells) Then
         .Value = sh2.Cells(i, "A").Text
         Else
         .Value = .Text & ", " & sh2.Cells(i, "A").Text
         End If
         Set fn = sh1.Range("B:B").FindNext(fn)
         End With
        Loop While fn.Address <> fAdr
      End If
  Next i
  
  'Now do word list on Sheet3
  
  For i = 1 To Sheet3LastRow
     Set fn = sh1.Range("B:B").Find(sh3.Cells(i, "A").Text, , xlValues, xlPart)
     If Not fn Is Nothing Then
        fAdr = fn.Address
        Do
         With fn.Offset(0, 1)
         If IsEmpty(.Cells) Then
         .Value = sh3.Cells(i, "A").Text
         Else
         .Value = .Text & ", " & sh3.Cells(i, "A").Text
         End If
         Set fn = sh1.Range("B:B").FindNext(fn)
         End With
        Loop While fn.Address <> fAdr
     End If
  Next i
End Sub
_____________________________________________

I should mention that if you plan to have a lot of sheets like Sheet1 and Sheet2, there would be a more efficient way of coding this, but for just two sheets simply repeating the code is the easiest way to go.

Best regards,

Damon

---------- FOLLOW-UP ----------

QUESTION: Hi Damon,

Thanks so much for all your help. I tried the code and it works perfectly however it copies the same word twice and I want only unique words as ooutput.

Regards,

Answer
Hi again Sofia,

This updated code should keep redundant keyword listings.

_________________________
Sub CopyBasedonSheet4()
  Dim i       As Long
  Dim j       As Long, fn As Range
  Dim sh1     As Worksheet, sh2 As Worksheet, sh3 As Worksheet
  Dim fAdr    As String
  Dim Sheet2LastRow    As Long
  Dim Sheet3LastRow    As Long
  Dim Keyword As String
  
  Set sh1 = Sheets("Sheet1")   'Sheet with sentences to be searched in col B
  Set sh2 = Sheets("Sheet2")   'Sheet with keyword list in column A
  Set sh3 = Sheets("Sheet3")   'Another sheet with keyword list in column A
  
  Sheet2LastRow = sh2.Cells(Rows.Count, "A").End(xlUp).Row
  Sheet3LastRow = sh3.Cells(Rows.Count, "A").End(xlUp).Row
  
  'Do word list on Sheet2
  
  For i = 1 To Sheet2LastRow
      Set fn = sh1.Range("B:B").Find(sh2.Cells(i, "A").Text, , xlValues, xlPart)
      If Not fn Is Nothing Then
        fAdr = fn.Address
        Do
         With fn.Offset(0, 1)
         Keyword = sh2.Cells(i, "A").Text
         If IsEmpty(.Cells) Then
         .Value = Keyword
         Else
         'ignore if the keyword is already listed
         If InStr(1, .Text, Keyword) = 0 Then
         .Value = .Text & ", " & Keyword
         End If
         End If
         Set fn = sh1.Range("B:B").FindNext(fn)
         End With
        Loop While fn.Address <> fAdr
      End If
  Next i
  
  'Now do word list on Sheet3
  
  For i = 1 To Sheet3LastRow
     Set fn = sh1.Range("B:B").Find(sh3.Cells(i, "A").Text, , xlValues, xlPart)
     If Not fn Is Nothing Then
        fAdr = fn.Address
        Do
         With fn.Offset(0, 1)
         Keyword = sh3.Cells(i, "A").Text
         If IsEmpty(.Cells) Then
         .Value = Keyword
         Else
         'ignore if the keyword is already listed
         If InStr(1, .Text, Keyword) = 0 Then
         .Value = .Text & ", " & Keyword
         End If
         End If
         Set fn = sh1.Range("B:B").FindNext(fn)
         End With
        Loop While fn.Address <> fAdr
     End If
  Next i
End Sub
_________________________________

Damon
About Excel
This topic answers questions related to Microsoft Excel spreadsheet (or workbook) stand-alone or Mircrosoft Office Excel including Excel 2003, Excel 2007, Office 2000, and Office XP. You can get Excel help on Excel formulas(or functions), Excell macros, charting in Excel, advanced features, and the general use of Excel. This does not provide a general Excel tutorial nor the basics of using a spreadsheet. It provides specific answers to using Microsoft Excel only. If you do not see your Excel question answered in this area then please ask an Excel question here

Excel

All Answers


Answers by Expert:


Ask Experts

Volunteer


Damon Ostrander

Expertise

I have extensive experience with VBA programming in Excel 5 through Excel 2013. As a former aerospace engineer with a large aerospace corporation and consultant in a small defense technology services company, I have developed a wide range of applications in VBA, including simulations involving mixed-language programming, satellite orbit mechanics, graphics and animation, and real-time applications. I am interested in moderate to hard VBA-related questions only.

Experience

I have developed and taught several courses in Excel VBA programming and also VBA programming in Office 97, 2000, and 2007. I have developed a number of large technical applications in Excel VBA for use within the aerospace industry.

Education/Credentials
B.S. in Electrical Engineering and Computer Science, University of California, Berkeley.

©2016 About.com. All rights reserved.