多次查找和分组结果

我有两个工作表：

Worksheet1有两列：A和B.

• ColA包含大约10,000个单元格，每个单元格都有文本句子。 每个单元的长度可以变化多达50个字。
• ColB包含ColA中每个单元格的唯一文本标签。

Worksheet2有一列ColA，它有超过18,000个单词。

所需要的是使用Worksheet2的ColA中的每个单词并在Worksheet1的ColA中find它，然后从ColB Worksheet1中检索它的标签或多个标签，为在第三个Worksheet3中search的每个单词分组。

例：
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 :(运行请求的代码之后）
ColA ColB
Case FG_Suya
four FG_Suya
_ SH84-Mindus
item SH84-Mindus

这个链接的代码是非常有用的，但它需要修改，以适应search词的多个实例，并对每个search词的结果进行分组，这些词将被放置在第三个工作表中。

对此事的援助表示高度赞赏。 提前致谢。

Answer 1

在这里，你如何开始思考这个问题。 该代码不使用Range.Find方法，但它使用Range.Value作为数组。 所以search运行更快，然后循环Range.Cells 。 如果你会testing它，那么我build议先采取less量的数据:-)。 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 

对于WorkSheet3中的示例数据，您应该看到：

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