用VBA实现在A列单元格内容里批量查找B列的多个关键词

quqiyuan

macos没有字典，使用数组循环，仅供参考。。。

quqiyuan

代码如下。。。
Sub test()
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("sheet1")
    r = sht.Cells(Rows.Count, 1).End(3).Row
    arr = sht.[a2].Resize(r - 1)
    r = sht.Cells(Rows.Count, 2).End(3).Row
    brr = sht.[b2].Resize(r - 1)
    ReDim crr(1 To UBound(arr), 0)
    For i = 1 To UBound(arr)
        s = Split(arr(i, 1), ",")
        ss = Empty
        For j = 0 To UBound(s)
            For k = 1 To UBound(brr)
                If brr(k, 1) = s(j) Then
                    ss = ss & "/" & brr(k, 1)
                End If
            Next
        Next
        crr(i, 0) = Mid(ss, 2)
    Next
    sht.[d2].Resize(UBound(crr)) = crr
    Beep
End Sub

ggmmlol

中药方剂的药材名称可不能胡乱提取，示例中第二行第一项为“川贝母”，显然应提取“川贝”而非“贝母”。
通常，这种关键字有相互包含的情况，必须按关键字的长度进行排序，然后以正则的“|”运算符将关键字并连起来进行匹配提取，这样可以避免把被包含的短关键字重复提取。
比如，“姜半夏”，提取之后，不宜再提取“半夏”，正则表达式提取时会消耗字符，可以避免重复提取。如果不用正则，可以用InStr函数判断关键字是否存在，如果存在，提取后应当用replace函数去掉已提取的关键字，达到“消耗字符”的效果。

总之，注意两点，一，关键字按长度降序排序，二，提取了的关键字应当消耗掉。

shiruiqiang

niushiping 发表于 2025-1-27 16:28

模拟到1万多，没问题

桑榆非晚123

Sub CompareAndMatchWithoutDictionary()
    Dim ws As Worksheet
    Dim lastRowA As Long, lastRowB As Long
    Dim AData As Variant, BData As Variant, result As Variant
    Dim i As Long, j As Long
    Dim wordsArray() As String
    Dim singleItem As String
    Dim results As String

    ' 获取当前工作表
    Set ws = ThisWorkbook.Sheets(1)

    ' 获取A列和B列的最后一行行号
    lastRowA = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    lastRowB = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row

    ' 读取A列和B列数据到内存
    AData = ws.Range("A1:A" & lastRowA).Value
    BData = ws.Range("B1:B" & lastRowB).Value

    ' 准备一个数组存储C列的结果
    ReDim result(1 To lastRowA, 1 To 1)

    ' 遍历A列数据
    For i = 1 To lastRowA
        If Not IsEmpty(AData(i, 1)) Then
            wordsArray = Split(AData(i, 1), ",") ' 按逗号分隔
            results = ""

            ' 遍历A单元格分割的中药名称，并与B列关键字逐一匹配
            For Each singleItem In wordsArray
                singleItem = Trim(singleItem) ' 去除空格
                For j = 1 To lastRowB
                    If singleItem = Trim(BData(j, 1)) Then
                        If results = "" Then
                            results = singleItem
                        Else
                            results = results & "/" & singleItem
                        End If
                        Exit For
                    End If
                Next j
            Next singleItem

            ' 将结果存入结果数组
            result(i, 1) = results
        Else
            result(i, 1) = "" ' 如果A单元格为空，则C单元格也为空
        End If
    Next i

    ' 将结果一次性写回C列
    ws.Range("C1:C" & lastRowA).Value = result

    ' 提示完成
    MsgBox "操作完成！结果已写入C列！", vbInformation
End Sub

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, cr, i&, j&, r&, strJoin$
   
    Application.ScreenUpdating = False
   
    r = Cells(Rows.Count, "B").End(xlUp).Row
    strJoin = "," & Join(Application.Transpose(Range("B1:B" & r).Value), ",") & ","
    ar = [A1].CurrentRegion.Value
    ReDim br(1 To UBound(ar), 0)
    For i = 2 To UBound(ar)
        cr = Split(ar(i, 1), ",")
        For j = 0 To UBound(cr)
            If InStr(strJoin, "," & cr(j) & ",") Then
                If Len(br(i, 0)) = 0 Then br(i, 0) = cr(j) Else br(i, 0) = br(i, 0) & "/" & cr(j)
            End If
        Next j
    Next i
   
    [C1].Resize(UBound(br)) = br
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk