CODEWITHSUNDEEP
vbaexcel
redd
redd

Reputation: 145

Finding text in a string then from a cell, then copying values over from the corresponding row to another cell

Here is what I want to happen:
In column A of Sheet2, each cell contains an email subject line. I want the macro to look through each cell and see if a cell from column D of Sheet1 is found somewhere within the subject line.

Then when this is found I want to copy over information from the row in Sheet1 corresponding to the cell from column D to column B in sheet 2 in the same row of the subject line the cell was found.

This is Sheet1 before the macro is run:

Sheet1

This is sheet2 before the macro is run:

Sheet2

Here is the code I have that does not work properly:

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

This is what happens after the macro has been ran:

Sheet2 Result

This is the outcome I want:

Sheet2 wanted Result

Upvotes: 0

Views: 1253

Answers (2)

Netloh
Netloh

Reputation: 4378

This code should return the desired result:

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

Upvotes: 1

R3uK
R3uK

Reputation: 14547

You were simply going to the last row of Sheet1 everytime, when filling the column "B" in Sheet2, in this line :

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

Try this :

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

Upvotes: 0

Related Questions