删除相互包含的单词并留下较长的单词

Question

我正在寻找一个宏（最好是一个函数），它可以获取单元格内容，将其拆分为单独的单词，将它们相互比较并删除较短的单词。

这是我希望输出的图像（我需要删除划掉的单词）：

我试着自己写一个宏，但它不能 100% 正常工作，因为它没有保留最后的话，有时会删除不应该删除的内容。此外，我必须在大约 50k 个单元格上执行此操作，因此宏需要花费大量时间才能运行，这就是为什么我更希望它是一个函数。我想我不应该使用 replace 函数，但我无法使任何其他功能正常工作。

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

一般步骤：

将单元格写入数组（已经工作）
对于每个元素 (x)，遍历每个元素 (y)（已经工作）
if x is in y AND y 比 x THEN 将 x 设置为 ""
concat数组返回字符串
将字符串写入单元格

String/array 操作比对单元格的操作快得多，因此这会给您带来一些性能提升（取决于您需要为每个单元格替换的单词量）。

"last word problem" 可能是因为您的单元格中的最后一个词后没有 space，因为您只将 word + " " 替换为 " "。

Answer 2

假设第一个示例中保留第三个词是错误的，因为 books 稍后包含在 notebooks 中：

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

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

正则表达式将：

捕捉每个单词
先行查看字符串中是否存在该词
- 如果有，删除它

由于 VBA 正则表达式也不能回溯，我们通过运行正则表达式在反向字符串上第二次来解决这个限制。

然后去掉多余的空格就大功告成了

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(?=.*)"
    .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 "word" 定义为仅包含 class [_A-Za-z0-9] 中的字符（字母、数字和下划线）。
如果任何单词可能被连字符，或包含其他非单词字符
- 在上面，它们将被视为两个单独的词
- 如果您希望将其视为单个单词，那么我们可能需要更改正则表达式

删除相互包含的单词并留下较长的单词

Remove words that contain each other and leave the longer one

excel

vba

user-defined-functions