VBA宏在两张图纸的两列中查找部分匹配项，并将值从图纸2复制到图纸1

Question

我是VBA初学者，但通过搜索这个论坛我已经学到了很多，我(有时(能够根据自己的需要修改代码。然而，我完全陷入了一个问题。我已经花了几个小时试图修改我在网上找到的示例，但我对VBA的理解还不够好，无法使其正常工作。如果有人能帮我解决以下问题，我将不胜感激。

我有一本两张的工作簿。工作表1上的B列包含数百行url(它们看起来像这样：https://website/news/2021/title-of-news-article)。该列有一个标题。表2的D列包含的行只包含其中一些url的最后一部分(新闻文章的标题(。此列还有一个标题。表2的E列包含与表2的D列中的部分URL相对应的值。还有一个标题。

我需要Excel来比较表2的D栏和表1的B栏。如果存在部分匹配，我希望Excel将相应的值从工作表2的E列复制到工作表1的F列中的相应行。

我已经找到了VBA代码，使我能够实现完全匹配。我正在使用一个类似下面的宏。但我不知道如何在部分比赛中做到这一点。也许我需要一个不同的解决方案？如果你需要更多信息，我很乐意提供。提前谢谢！

Sub Test
Dim w1 As Worksheet, w2 As Worksheet
Dim c As Range, FR As Long
Application.ScreenUpdating = False
Set w1 = Worksheets("sheet2")
Set w2 = Worksheets("sheet1")
For Each c In w1.Range("F2", w1.Range("A" & Rows.Count).End(xlUp))
FR = 0
On Error Resume Next
FR = Application.Match(c, w2.Columns(1), 0)
On Error GoTo 0
If FR <> 0 Then w2.Range("E" & FR).value = c.Offset(, 1)
Next c
Application.ScreenUpdating = True
End Sub`

Answer 1

试试这个。我可能没有把所有的细节都弄对，但看看你进展如何。

Sub Test()
Dim w1 As Worksheet, w2 As Worksheet
Dim c As Range, r As Range
Application.ScreenUpdating = False
Set w1 = Worksheets("sheet1") 'think these names make more sense!
Set w2 = Worksheets("sheet2")
For Each c In w2.Range("D2", w2.Range("D" & Rows.Count).End(xlUp)) 'loop through D
Set r = w1.Columns(2).Find(What:=c.Value, LookIn:=xlFormulas, Lookat:=xlPart, MatchCase:=False, SearchFormat:=False)
If Not r Is Nothing Then  'found in B
w1.Range("F" & r.Row).Value = c.Offset(, 1).Value 'copy E to F
End If
Next c
Application.ScreenUpdating = True
End Sub