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

Question

我有2列（A＆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

Edit2：一旦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