求编写Excel VBA代码：按指定单词出现次数截取单元格内容

Sub removeData()
    Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
    Dim i As Long, lr As Long
    Dim cellText As String, lowerText As String, lowerTarget As String
    Dim occurrences As Integer, firstPos As Long, lastPos As Long
    Const targetWord As String = "Adam" ' 修改此处为你需要的指定单词
    Dim targetLen As Integer: targetLen = Len(targetWord)
    
    lr = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
    
    For i = 1 To lr
        cellText = ws.Range("A" & i).Value
        ' 处理空单元格
        If cellText = "" Then
            ws.Range("D" & i).Value = ""
            GoTo NextRow
        End If
        
        ' 不区分大小写计算目标单词出现次数
        lowerText = LCase(cellText)
        lowerTarget = LCase(targetWord)
        occurrences = UBound(Split(lowerText, lowerTarget))
        
        Select Case occurrences
            Case 0
                ' 未出现目标单词，保留原内容
                ws.Range("D" & i).Value = cellText
            Case 1
                ' 仅出现一次，删除目标单词及其之后的内容
                firstPos = InStr(1, cellText, targetWord, vbTextCompare)
                ws.Range("D" & i).Value = Trim(Left(cellText, firstPos - 1))
            Case Else
                ' 出现多次，删除最后一次出现的目标单词及其之后的内容
                lastPos = InStrRev(cellText, targetWord, , vbTextCompare)
                ws.Range("D" & i).Value = Trim(Left(cellText, lastPos - 1))
        End Select
        
NextRow:
    Next i
End Sub

代码说明 #

• 自定义目标单词：修改Const targetWord As String = "Adam"中的值，即可切换需要匹配的单词。
• 不区分大小写匹配：通过转小写计算出现次数，结合vbTextCompare参数实现大小写不敏感的位置查找，适配示例中adam和Adam的场景。
• 分支逻辑：
  • 未匹配到目标单词：直接保留原单元格内容。
  • 仅匹配一次：截取目标单词首次出现位置之前的内容，自动去除末尾多余空格。
  • 匹配多次：截取目标单词最后一次出现位置之前的内容，自动去除末尾多余空格。
• 空单元格处理：直接输出空值，避免运行报错。

示例验证 #

1. 原内容：adam ate a pear. Adam ate an apple → 处理后：Adam ate a pear.
2. 原内容：adam ate a pear → 处理后：空白单元格

内容的提问来源于stack exchange，提问作者ExcelG