vba - Microsoft Excel 从单独的列表中清除所有不包含至少 1 个关键字的短语行

Question

在一个常规文本文件中，我有一个包含大约 1,000 个不同关键字的列表（非常直接。它们都是没有空格的单个单词，并且每个关键字后面都有一个硬返回）。

关键字列表.txt

彼得

詹姆士

约翰

玛丽

克里斯

然后我有一个 Excel 文件，其中包含 A 列中 100,000 个不同短语的列表（每行一个短语）。

我想从我的第一个列表中删除所有不包含至少 1 个关键字的行。

短语.xlsx（这些大多是长短语，有些超过 254 个字符，每行一个短语）

第 1 行“他和玛丽在这里”（保留这一行，因为我的关键字中有一个或多个）

第 2 行“那个叫彼得和克里斯的男孩”（保留这一行，因为我有一个或多个关键字）

第 3 行“Michael and Ronald are there”（注意：没有关键字出现，因此删除整行）

这可以单独在Excel中完成吗？还是我需要一个宏？如果它不像看起来那么简单，请引导我朝着正确的方向前进。我不了解 VBA 或宏，但如果 Excel 中没有简单的方法，我会尽力而为 :) 谢谢，Alex

score 1 · Accepted Answer

执行此操作的非 VBA 将通过文本导入向导将您的文件导入工作簿中的另一个工作表。在您的原始工作表中，使用数组公式（不要忘记 Ctrl+Shift+Enter）并双击角向下拖动：

=MAX(IFERROR(FIND(Keywords!$A$1:$A$5,$A1,1),0))

关键字是包含导入数据的工作表，A1 是您的第一个短语所在的单元格，假设您在 B1 中输入了此公式。您将有一系列起始位置编号，任何为零都意味着在短语中找不到任何关键字 - 这是 IFERROR 公式中的 0。然后，您可以按 0 过滤列 B 并删除可见单元格（选择 > Ctrl+G > 特殊 > 仅可见单元格 > 删除行）。

在您上面提供的示例中，第一个公式将产生 (0, 0, 0, 9, 0)。MAX 然后挑选出最大的数字。

编辑

正如评论中所讨论的，这也将拾取部分内容，例如在“灾难”中找到“猫”。要解决此问题，您可以在两个工作表中创建一个临时列，在关键字和短语之前和之后添加一个空格：

=" "&$A1&" "

重新执行公式以指向两个工作表中的临时列。在您的关键字范围中添加空格确保它只找到那个确切的词组；在短语中添加空格将确保它会找到短语以关键字开头或结尾的实例。

score 0 · Accepted Answer

更新：让我们在 VBE 中创建一个空白工作簿和一个新模块，然后粘贴代码，保存为启用宏的工作簿 (.xlsm)，更改宏安全设置，重新打开这个 .xlsm 文件。

在 Excel 中按 Alt-F11 打开 Visual Basic

单击插入-> 模块

插入模块

双击 Module1 或它刚刚创建的任何内容

模块1

粘贴下面的代码

Const ForReading = 1
' Change these two below to match your file path
Const KeyWordsFile = "C:\Test\keywordslist.txt"
Const PhrasesFile = "C:\Test\phrases.xlsx"    

Sub SO_19150262()
    Dim aKeywords As Variant, oWB As Workbook, oWS As Worksheet
    Dim R As Long, i As Long, bDelete As Boolean, sTmp As String

    Application.ScreenUpdating = False
    ' Read the Keywords file into aKeywords (array)
    aKeywords = GetKeywords(KeyWordsFile)
    Set oWB = Workbooks.Open(Filename:=PhrasesFile, ReadOnly:=False)
    Set oWS = oWB.Worksheets("Sheet1") ' Change this to match yours
    ' Start comparing from bottom of used data
    For R = oWS.UsedRange.Cells.SpecialCells(xlLastCell).Row To 1 Step -1
        bDelete = True
        sTmp = "Deleting Row " & R
        For i = 0 To UBound(aKeywords)
            If Len(aKeywords(i)) > 0 Then
                Application.StatusBar = "Checking Row " & R & " for keyword """ & aKeywords(i) & """..."
                If InStr(1, oWS.Cells(R, 1).Value, aKeywords(i), vbTextCompare) > 0 Then
                    sTmp = "Keeping Row " & R & ", Keyword(" & i & "):""" & aKeywords(i) & """"
                    bDelete = False
                    Exit For
                End If
            End If
        Next
        Debug.Print sTmp
        If bDelete Then oWS.Rows(R).Delete
    Next
    oWB.Save
    Set oWS = Nothing
    Set oWB = Nothing
    Application.StatusBar = False
    Application.ScreenUpdating = True
End Sub

Private Function GetKeywords(sKeyFile As String) As Variant
    Dim aKeys As Variant, oFSO As Variant, oFile As Variant

    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFile = oFSO.OpenTextFile(KeyWordsFile, ForReading)
    If (oFile.AtEndOfStream) Then
        aKeys = Array()
    Else
        aKeys = Split(oFile.ReadAll, vbCrLf) ' Might need to change to vbCr or vbLf if unix text file
    End If
    Set oFile = Nothing
    Set oFSO = Nothing
    GetKeywords = aKeys
End Function

然后在 Excel 中，另存为 ->“启用 Excel 宏的工作簿”

另存为