从单元格中的列表中删除多个单词

Question

I have a list of entities names that I want to extract keywords out of those. So I want to remove a list of words like "company", "ltd", "university", "of", "and", etc. from all the names. The list of "removal words" is about 20 items so using SUBSTITUTE won't work. Is there a way to achieve that? Formula and VBA are ok. If possible, the method should give the user the ability to add, reduce or edit the list of "removal words" in excel. What I want look something like this:

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

You need to loop through the list of "removal words" and .Replace each of the words with blank expression:

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

along the lines of @AntiDrondert 's code, but with some variations and putting results in sheet "Names" column 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 also gave this code. Just use function ClearWords(A1,Range) to get the result in any cell. I think this is also very good solution as it includes the "removal words" as a range variable.

 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