Поиск текста в строке, затем из ячейки, затем копирование значений из соответствующей строки в другую ячейку

Question

Вот что я хочу:
В столбце A листа 2 каждая ячейка содержит строку темы сообщения электронной почты. Я хочу, чтобы макрос просматривал каждую ячейку и видел, что ячейка из столбца D листа 1 найдена где-то внутри строки темы.

Затем, когда это будет найдено, я хочу скопировать информацию из строки в Листе 1, соответствующей ячейке из столбца D, в столбец B на листе 2 в той же строке строки темы, в которой была найдена ячейка.

Это Лист1 перед запуском макроса:

Это sheet2 перед запуском макроса:

Вот код, у меня это не работает надлежащим образом:

Sub Path() 

Dim rCell As Range 
Dim rRng As Range 

Sheets("Sheet2").Activate 
Set rRng = Range("A2:A65000") 

With Sheets(1).Activate 
    For i = 1 To Sheets("Sheet1").Cells(Rows.Count, "D").End(xlUp).Row 
     For Each rCell In rRng.Cells 

      If InStr(1, rCell, Sheets("Sheet1").Cells(i, "E").Value, vbTextCompare) Then 
       Sheets("Sheet2").Cells(i, "B") = "1. Invoices+BUFs - " & Sheets("Sheet1").Range("B65000").End(xlUp).Value & "\" & Sheets("Sheet1").Range("A65000").End(xlUp).Value & " - " & Sheets("Sheet1").Range("C65000").End(xlUp).Value & "\" & "LOGGED" & "\" & Sheets("Sheet1").Range("D65000").End(xlUp).Value 
      End If 

     Next rCell 
    Next i 
End With 

End Sub 

Это то, что происходит после того, как макрос был RAN:

Это результат я хочу:

Answer 1

Этот код должен вернуть желаемый результат:

Sub Path() 
    Dim s1 As Worksheet 
    Dim s2 As Worksheet 
    Dim i As Long 
    Dim j As Long 

    Set s1 = ActiveWorkbook.Sheets("Sheet1") 
    Set s2 = ActiveWorkbook.Sheets("Sheet2") 

    Application.ScreenUpdating = False 

    'Loop sheet 2 
    For i = 1 To s2.Cells(Rows.Count, 1).End(xlUp).Row 
     'Loop sheet 1 
     For j = 1 To s1.Cells(Rows.Count, 1).End(xlUp).Row 
      'If match found 
      If Not InStr(1, s2.Cells(i, 1).Value, s1.Cells(j, 4).Value) = 0 Then 
       s2.Cells(i, 2).Value = "1. Invoices+BUFs - " & s1.Cells(j, 2).Value & "\" & s1.Cells(j, 1).Value & " - " & s1.Cells(j, 3).Value & "\" & "LOGGED" & "\" & s1.Cells(j, 4).Value 
       Exit For 
      End If 
     Next j 
    Next i 

    Application.ScreenUpdating = True 
End Sub 

Answer 2

Вы просто переходите к последнему ряду Sheet1 каждый раз, когда заполняете столбец «B» в Sheet2, в эта линия:

Sheets("Sheet2").Cells(i, "B") = _ 
    MAIN_PATH & "1. Invoices+BUFs - " & _ 
    Sheets("Sheet1").Range("B65000").End(xlUp).Value & "\" & _ 
    Sheets("Sheet1").Range("A65000").End(xlUp).Value & " - " & _ 
    Sheets("Sheet1").Range("C65000").End(xlUp).Value & "\" & "LOGGED" & "\" & _ 
    Sheets("Sheet1").Range("D65000").End(xlUp).Value 

Попробуйте это:

Sub Path() 

Dim rCell As Range 
Dim rRng As Range 

Set rRng = Sheets("Sheet2").Range("A2:A" & Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row) 

With Sheets("Sheet1") 
    For Each rCell In rRng.Cells 
     For i = 1 To .Cells(Rows.Count, "D").End(xlUp).Row 

      If Sheets("Sheet2").Cells(rCell.Row, "B") <> "FILLED" Then 
       If InStr(1, rCell, .Cells(i, "E").Value, vbTextCompare) Then 

        Sheets("Sheet2").Cells(rCell.Row, "B") = _ 
         "1. Invoices+BUFs - " & _ 
         .Cells(i, "B") & "\" & _ 
         .Cells(i, "A") & " - " & _ 
         .Cells(i, "C") & "\" & _ 
         "LOGGED" & "\" & _ 
         .Cells(i, "D") 
        Exit For 

       End If 
      Else 
      End If 

     Next i 
    Next rCell 

End With 

Set rRng = Nothing 

End Sub