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"
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
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
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
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.