Copy cells if the specific text is present in the cell

[Maruthiveer]

I have an excel sheet with units on Column B, and the dates on the row A1 as headers from "F"., if any cell contain the word apple , the need to copy that respective ID and the date in a new sheet.

For example :
Master sheet.

Sold by	Apple units	sale	Market	Total Units	3/1/2020​	3/2/2020​	3/3/2020​	3/4/2020​
Ram	53​			198​	Orange	Apple	Banana	Rose
Ravi	68​			189​	Apple	Rose	orange	Apple

After running the code :

Result should be like:

Apple Units	dates
53​	3/2/2020​
68​	3/1/2020​
68​	3/4/2020​

can anyone help me with the code, where the cells with text APPLE - relevant apple units and date will pulled on sheet2.

Thanks

 

[JLGWhiz]

Sub t()
Dim c As Range, i As Long, sh1 As Worksheet, sh2 As Worksheet
Set sh1 = Sheets("Master") 'Edit sheet name-Source sheet
Set sh2 = Sheets("Sheet2") 'Edit sheet name-destination sheet
    With sh1
        For Each c In .Range("F2", .Cells(Rows.Count, "F").End(xlUp))
            For i = 6 To .Cells(c.Row, Columns.Count).End(xlToLeft).Column
                If LCase(.Cells(c.Row, i)) = "apple" Then
                    sh2.Cells(Rows.Count, 1).End(xlUp)(2) = c.Offset(, -4).Value
                    sh2.Cells(Rows.Count, 1).End(xlUp).Offset(, 1) = .Cells(1, i).Value
                End If
            Next
        Next
    End With
End Sub

 

[Maruthiveer]

Wow it's amazing. Thanks a lot

i am just wondering can we also pull the cells even the row containing the word apple has some text in it .

For example :

Sold by	Apple units	sale	Market	Total Units	3/1/2020	3/2/2020	3/3/2020	3/4/2020
Ram	53			198	Orange	7:00-15:00 Apple: 40	Banana	Rose
Ravi	68			189	8:00-16:00 Apple: 90	Rose	orange	10:00-19:00 Apple: 75

can we still get the data ? i tried with the above code but i didn't get the result .

 

[JLGWhiz]

i am just wondering can we also pull the cells even the row containing the word apple has some text in it .

Maybe this

Sub t2()
Dim c As Range, i As Long, sh1 As Worksheet, sh2 As Worksheet
Set sh1 = Sheets("Master") 'Edit sheet name-Source sheet
Set sh2 = Sheets("Sheet2") 'Edit sheet name-destination sheet
    With sh1
        For Each c In .Range("F2", .Cells(Rows.Count, "F").End(xlUp))
            For i = 6 To .Cells(c.Row, Columns.Count).End(xlToLeft).Column
                If InStr(.Cells(c.Row, i).Value, "apple") > 0 Then
                    sh2.Cells(Rows.Count, 1).End(xlUp)(2) = c.Offset(, -4).Value
                    sh2.Cells(Rows.Count, 1).End(xlUp).Offset(, 1) = .Cells(1, i).Value
                End If
            Next
        Next
    End With
End Sub