然后从单元格中查找字符串中的文本，然后将值从相应的行复制到另一个单元格

Question

这就是我想要发生的事情：
在Sheet2的A列中，每个单元格都包含一个电子邮件主题行。我希望宏能够查看每个单元格，看看是否在主题行的某个位置找到了Sheet1列D的单元格。

然后，当发现这个时，我想要从Sheet1中的行中复制信息，该信息对应于从主题行的相同行中的第2列D列到B列的单元格。

这是运行宏之前的Sheet1：

这是运行宏之前的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

这是宏运行后发生的事情：

这是我想要的结果：

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

当你填写Sheet2中的“B”列时，你只是每次都去Sheet1的最后一行：

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