從單元格中的列表中刪除多個單詞

Question

我有一個實體名稱列表，我想從中提取關鍵字。 所以我想從所有名稱中刪除諸如“company”、“ltd”、“university”、“of”、“and”等詞的列表。 “刪除詞”列表大約有 20 個項目，因此使用 SUBSTITUTE 將不起作用。 有沒有辦法實現這一目標？ 公式和 VBA 沒問題。 如果可能，該方法應使用戶能夠在 excel 中添加、減少或編輯“刪除詞”列表。 我想要的是這樣的：

Sheet "Names" Input
Cell A1-A4 = "Apple Co. Ltd.", "Orange University", "Excel company", "Mountain trading and renting company Ltd."
Sheet "Removal"
Cell A1-A4 = "company", "co.", "Co.", "Ltd."
Sheet "Names" Result
Cell B1-B4 = "Apple", "Orange University", "Excel", "Mountain trading and renting"

Answer 1

你通過“去除詞”的名單需要循環.Replace每個與無表情的話：

Sub RemoveWords()
    Dim vArr(), i As Long
    Dim rngChange As Range
    'Store Removal values in array
    With ThisWorkbook.Worksheets("Removal")
        vArr = Application.Transpose(.Range("A1:A" & .Range("A" & .Rows.Count).End(xlUp).Row).Value)
    End With
    With ThisWorkbook.Worksheets("Names")
        'Define range where replacements will be made
        Set rngChange = .Range("A1:A" & .Range("A" & .Rows.Count).End(xlUp).Row)

        'To use another column, uncomment the following lines:
        'Set rngChange = .Range("B1:B" & .Range("A" & .Rows.Count).End(xlUp).Row)
        'rngChange.Value = .Range("A1:A" & .Range("A" & .Rows.Count).End(xlUp).Row).Value

        'Loop through array of words to be removed
        For i = LBound(vArr) To UBound(vArr)
            'Replace "removal word" with blank expression
            rngChange.Replace vArr(i), "", xlPart
        Next i
        'Trim cells in range
        rngChange.Value = Evaluate("IF(ROW(),TRIM(" & rngChange.Address & "))")
    End With
End Sub

Answer 2

沿着@AntiDrondert 的代碼行，但有一些變化並將結果放在表“名稱”列 B 中：

Sub RemoveWords()
    Dim wordsToRemove As Variant, word As Variant

    With Worksheets("Removal") 'reference "Removal" worksheet
        wordsToRemove = Application.Transpose(.Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Value) ' store
    End With
    With Worksheets("Names") 'reference "names" worksheet
        With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)) ' reference referenced worksheet column A cells from row 1 down to last not empty row
            .Offset(, 1).Value = .Value ' copy values one column to the left
            For Each word In wordsToRemove 'loop through words to be removed array
                .Offset(, 1).Replace word, "", xlPart 'replace current word in referenced range one column to the left
            Next
        End With
    End With
End Sub

Answer 3

Peter_SSs 也給出了這個代碼。 只需使用函數 ClearWords(A1,Range) 即可在任何單元格中獲得結果。 我認為這也是一個很好的解決方案，因為它包含“刪除詞”作為范圍變量。

 Function ClearWords(s As String, rWords As Range) As String
      'By Peter_SSs, MrExcel MVP
      Static RX As Object
      
      If RX Is Nothing Then
        Set RX = CreateObject("VBScript.RegExp")
        RX.Global = True
        RX.IgnoreCase = True
      End If
      RX.Pattern = "\b" & Replace(Join(Application.Transpose(rWords), "|"), ".", "\.") & "\b"
      ClearWords = Application.Trim(RX.Replace(s, ""))
    End Function