Question

我有一个实体名称列表，我想从中提取关键字。所以我想删除一些单词列表，例如＆＃34; company＆＃34;，＆＃34; ltd＆＃34;，＆＃34; university＆＃34;，＆＃34; of＆＃34;，＆＃34;和所有名字的＆＃34;等。＆＃34;删除单词列表＆＃34;约有20个项目，因此使用SUBSTITUTE无法正常工作。有没有办法实现这一目标？公式和VBA都可以。如果可能，该方法应该使用户能够添加，减少或编辑＆＃34;删除词的列表＆＃34;在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

您需要遍历＆＃34;删除字词列表＆＃34;和.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

有人也提供此代码。只需使用函数ClearWords（A1，Range）即可在任何单元格中获取结果。我认为这也是一个非常好的解决方案，因为它包括＆＃34;删除词＆＃34;作为范围变量。

 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

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

3 个答案: