2列之间的部分匹配，导致另一列

Question

我有2列（A＆amp; B），我想在列C中获得这两列的部分匹配。例如：

A
Lore: Excavator
Lore: Scribe
Athletics: Strong Back
Healing: Medicine
Melee: No Mercy
Insight: Sixth Sense
Melee: Strong Man
Parry: Stage Fighting
Healing: Cure Wounds
Craft: Journeyman
Craft: Master Crafter
Discipline: Courageous
Discipline: Jaded
Linguistics: Accent
Stealth: Living Shadows

B
----
Lore
Healing
Parry
Stealth
Craft

C (Should be)
----
Lore: Excavator
Lore: Scribe
Healing: Medicine
Healing: Cure Wounds
Parry: Stage Fighting
Stealth: Living Shadows
Craft: Journeyman
Craft: Master Crafter

ps：这只是一个示例列表。通常，A列表将包含更多条目，但B列始终具有5个值

谢谢

Answer 1

您可以尝试更简单的代码，

Sub findMatch()
Dim i As Long, j As Long, k As Long
k = 1
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
    For j = 1 To 5
        If InStr(Cells(i, 1), Cells(j, 2)) Then
            Cells(k, 3) = Cells(i, 1)
            k = k + 1
        End If
    Next j
Next i
End Sub

Answer 2

编辑2：一旦G50中有五个条目，该版本将自动更新：G54或该范围中的一个条目已更改。将其放在数据所在工作表的工作表代码中。此代码很容易更新，以检查您想要的任何范围（只需更改rng1，rng2或rng3）。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Dim rng1 As Range, rng2 As Range, rng3 As Range

Set ws = ActiveSheet
Set rng1 = ws.Range("D50:D80")
Set rng2 = ws.Range("G50:G54")
Set rng3 = ws.Range("H50:H80")

If Not Intersect(rng2, Target) Is Nothing Then
    If Application.CountA(rng2) >= 5 Then
        rng3.ClearContents
        For x = rng1.Cells(1, 1).Row To rng1.Cells(1, 1).Row + Application.CountA(rng1) - 1
            For y = rng2.Cells(1, 1).Row To rng2.Cells(1, 1).Row + Application.CountA(rng2) - 1
                If InStr(rng1.Cells(x - rng1.Cells(1, 1).Row + 1, 1).Text, rng2.Cells(y - rng2.Cells(1, 1).Row + 1, 1).Text) Then
                    ws.Cells(Application.CountA(rng3) + rng3.Cells(1, 1).Row, rng3.Cells(1, 1).Column).Formula = rng1.Cells(x - rng1.Cells(1, 1).Row + 1, 1).Text
                End If
            Next y
        Next x
    End If
End If

End Sub