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