Excel 查找函数从包含句子的活动单元格中查找整个单词,而不是单个字符

Excel find function to find whole words from an active cell containing sentences, and not individual characters

附件是我到目前为止的代码。我的问题是,我似乎无法让宏仅将整个单词 sheet(2) B 列活动单元格(单元格中包含多个单词)与 [= 中的范围(A 列)进行比较38=](1) - 这是一个完整单词的列表(如下图所示)。代码中的其他所有内容都可以正常工作,但目前它仅适用于完全匹配?

我尝试过使用通配符方法,但它似乎可以匹配任何字符,而我需要它来比较句子中的整个单词(在活动单元格中每次都不同)。

关于我可以添加什么以便 countif 函数找到整个单词而不是字符等的任何提示? Find 函数也存在同样的问题,它只会找到完全匹配项,如果找不到完全匹配项,则会出现 return 错误。

    Sub FMEATest1()

Dim count As Integer
Dim count2 As Integer
Dim n As Integer
Dim m As Integer
Dim FML As Range
Dim i As Range
'Dim m As Integer
Dim a As Range
Dim b As Integer
Dim FML2 As Range
Dim WrdArray() As String
Dim k As Range
Dim j As Range
Dim Splitsentence As Range
Worksheets(1).Activate


Range(("A1"), Range("A1").End(xlDown)).Select

Set FML = Selection

Worksheets(2).Activate

Range("B3").Activate

Do Until ActiveCell.value = ""
Set i = ActiveCell
WrdArray() = Split(i, , , vbTextCompare)
Set Splitsentence = WrdArray().value

count = Application.WorksheetFunction.CountIf(FML, Splitsentence)

     'm = (ActiveCell.Row) + count - 1

    n = Selection.Rows.count

    Do Until n = (count)

     ActiveCell.Offset(1, 0).EntireRow.Insert
     Set a = Selection.Offset(1, 0)
        ActiveCell.COPY
        ActiveCell.Offset(1, 0).value = ActiveCell.value
        ActiveCell.PasteSpecial
     Range(i, a).Select

    n = Selection.Rows.count
    Loop

    'Copying Failure Modes for each Keyword
         Lookfor = ActiveCell.value & "*"
         Worksheets(1).Activate
         Cells.Find(What:=Lookfor, After:=ActiveCell, LookIn:=xlValues, _
        LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False).Select

        Set FML2 = Selection
        Set j = ActiveCell
     count2 = Application.WorksheetFunction.CountIf(FML2, j)
     m = Selection.Rows.count
     Do Until m = (count)

    Set k = Selection.Offset(1, 0)
        Range(j, k).Select
        m = Selection.Rows.count
    Loop

    Selection.Offset(0, 1).COPY
    Worksheets(2).Activate
    ActiveCell.Offset(0, 1).PasteSpecial


    ActiveCell.Offset(n, -1).Activate

    Loop

    End Sub

困难在于activecell包含一个句子,这个句子每次都不同,如下例所示,但我需要宏来匹配sheet(2)中B列的整个关键字到Column sheet 中的 A (1)。

有人可以公开我的图片吗?

所以我会寻找能够从整个句子的单元格 B3 中找到单词 "charge" 的代码(并在 sheet 的 A 列中找到它( 1)).以及整个句子中 B4 中的单词 "Hold"。这些可能会发生很大变化,所以我无法手动将它们输入到我需要引用 activecell 的查找函数中。

代码的最终解决方案应给出以下结果(我已经为 "charge" 和 "hold" 给出了两个示例):

我假设了评论中概述的数据,因此您可能需要修改 sheet 名称和范围。此外,根据您 sheet 中的其他数据,它可能需要对输出进行一些调整,但如果您根据屏幕截图模拟一个示例,它应该可以按预期工作。

Sub x()

Dim v, vOut(), i As Long, j As Long, k As Long, va, r As Range, r1 As Long

'Assumes list of words in A1/B1 and down on "Sheet1"
Set r =Sheets("Sheet1").Range("A1").CurrentRegion

With Sheets("Sheet2") 'Assumes phrases in B1 and down on "Sheet2"
    v = .Range("B1", .Range("B" & Rows.Count).End(xlUp)).Value
    .Columns(2).ClearContents
End With

ReDim vOut(1 To UBound(v) * r.Rows.Count, 1 To 2)

For i = LBound(v, 1) To UBound(v, 1)
    va = Split(v(i, 1))
    For j = LBound(va) To UBound(va)
       For r1 = 1 To r.Rows.Count
          If LCase(Application.Trim(va(j))) = LCase(r.Cells(r1, 1)) Then
             k = k + 1
             vOut(k, 1) = v(i, 1)
             vOut(k, 2) = r.Cells(r1, 2)
          End If
       Next r1
    Next j
Next i

Sheets("Sheet2").Range("B1").Resize(k, 2) = vOut 'Puts results in B1/C1 and down on "Sheet2"

End Sub