Multiple find and grouping of results

Question

I have two worksheets:

Worksheet1 has two columns: A & B.

ColA contains about 10,000 cells each has sentences of text only. Each cell varies in length up to 50 words.
ColB contains unique text tags for each cell in ColA.

Worksheet2 has one column, ColA, which has over 18,000 single words.

What's required is to use every word in ColA of Worksheet2 and find it in ColA of Worksheet1, then retrieve its tag or multiple tags from ColB Worksheet1 grouped for every word searched in third Worksheet3.

Example:
Worksheet1:
ColA ColB
Case four adjourned till Jan2011 FG_Suya
Item four modified permanently SH84-Mindus

Worksheet2:
ColA
case
four
item
item four modified

Worksheet3: (after running the requested code)
ColA ColB
Case FG_Suya
four FG_Suya
_ SH84-Mindus
item SH84-Mindus

Code at this link is very useful, but it needs to be modified to accommodate for finding multiple instances of a searched word, and grouping of findings per searched word which is to be placed in a third worksheet.

Assistance in this matter is highly appreciated. Thanks in advance.

Daniel Dušek Daniel Dušek · Accepted Answer · 2014-11-02T21:27:59

Here sample of how could you start to think about it. The code doesn't use Range.Find method, but it uses Range.Value as array. So the searching runs faster then looping over Range.Cells. If you will test it then I recommend to take small amount of data first :-). HTH.

Option Explicit

Private Const TextsSheetName As String = "Worksheet1"
Private Const WordsSheetName As String = "Worksheet2"
Private Const ResultsSheetName As String = "Worksheet3"

Private m_textsSheet As Worksheet
Private m_wordsSheet As Worksheet
Private m_resultsSheet As Worksheet

Private m_texts() As Variant
Private m_words() As Variant

Sub JosefMiller()
    Set m_textsSheet = Worksheets(TextsSheetName)
    Set m_wordsSheet = Worksheets(WordsSheetName)
    Set m_resultsSheet = Worksheets(ResultsSheetName)

    m_texts = m_textsSheet.UsedRange
    m_words = m_wordsSheet.UsedRange

    Dim w As Long
    Dim t As Long
    Dim r As Long
    Dim foundThisWord As Boolean

    For w = LBound(m_words) To UBound(m_words)
        foundThisWord = False
        For t = LBound(m_texts) To UBound(m_texts)
            If (InStr(1, m_texts(t, 1), m_words(w, 1), vbTextCompare) > 0) Then
                r = r + 1
                If Not foundThisWord Then
                    m_resultsSheet.Range("A" & r) = m_words(w, 1)
                Else
                    m_resultsSheet.Range("A" & r) = "_"
                End If
                m_resultsSheet.Range("B" & r) = m_texts(t, 2)
                foundThisWord = True
            End If
        Next t
    Next w
End Sub

For the sample data in the WorkSheet3 you should see:

case                FG_Suya
four                FG_Suya
_                   SH84-Mindus
item                SH84-Mindus
item four modified  SH84-Mindus

Multiple find and grouping of results

1 Answers