删除相互包含的单词，留下更长的单词

我正在寻找一个macros（最好是一个函数），将单元格内容，拆分成单独的单词，比较他们，并删除较短的单词。

这是一个我想要的输出图像（我需要去除的字符）：

我试图自己写一个macros，但它不能正确工作，因为它没有采取最后的措辞，有时删除不应该被删除的东西。 另外，我必须在5万个左右的单元上做这个，所以一个macros需要很多时间来运行，这就是为什么我更喜欢它是一个函数。 我想我不应该使用replacefunction，但我不能做任何其他工作。

 Sub clean_words_containing_eachother() Dim sht1 As Worksheet Dim LastRow As Long Dim Cell As Range Dim cell_value As String Dim word, word2 As Variant Set sht1 = ActiveSheet col = InputBox("Which column do you want to clear?") LastRow = sht1.Cells(sht1.Rows.Count, col).End(xlUp).Row Let to_clean = col & "2:" & col & LastRow For i = 2 To LastRow For Each Cell In sht1.Range(to_clean) cell_value = Cell.Value cell_split = Split(cell_value, " ") For Each word In cell_split For Each word2 In cell_split If word <> word2 Then If InStr(word2, word) > 0 Then If Len(word) < Len(word2) Then word = word & " " Cell = Replace(Cell, word, " ") ElseIf Len(word) > Len(word2) Then word2 = word2 & " " Cell = Replace(Cell, word2, " ") End If End If End If Next word2 Next word Next Cell Next i End Sub 

Answer 1

假设在第一个例子中保留第三个单词是一个错误，因为书本后来被包含在笔记本中 ：

 5003886 book books bound case casebound not notebook notebooks office oxford sign signature 

并假设你想要删除重复的相同的单词，即使它们没有包含在另一个单词中，那么我们可以使用正则expression式。

正则expression式将：

• 捕捉每个单词
• 向前查看该字词后面是否存在该字词
  • 如果是这样，请删除它

由于VBA正则expression式不能同时隐藏，我们通过在反向string上运行正则expression式来解决这个限制。

然后删除多余的空间，我们完成了。

 Option Explicit Function cleanWords(S As String) As String Dim RE As Object, MC As Object, M As Object Dim sTemp As String Set RE = CreateObject("vbscript.regexp") With RE .Global = True .Pattern = "\b(\w+)\b(?=.*\1)" .ignorecase = True 'replace looking forward sTemp = .Replace(S, "") ' check in reverse sTemp = .Replace(StrReverse(sTemp), "") 'return to normal sTemp = StrReverse(sTemp) 'Remove extraneous spaces cleanWords = WorksheetFunction.Trim(sTemp) End With End Function 

限制

• 标点符号不会被删除
• 一个“单词”被定义为只包含类[_A-Za-z0-9] （字母，数字和下划线）中的字符。
• 如果任何单词可能被连字符，或包含其他非单词字符
  • 在上面，他们将被视为两个单独的词
  • 如果你想把它看作一个单词，那么我们可能需要改变正则expression式

Answer 2

一般步骤：

• 写入单元格到数组（已经工作）
• 对于每个元素（ x ），遍历每个元素（ y ）（已经工作）
• 如果x 在 y 并且 y x长的话那么将x设置为""
• 连接数组回到string
• 将string写入单元格

string/数组操作比单元上的操作要快得多，所以这会提高性能（取决于每个单元需要replace的字数）。

“最后一个字的问题”可能是你的单元格中的最后一个单词之后没有空格，因为你只能用word + " "replaceword + " " " " 。