Try:
Sub BPSJACKzz()
Dim y As String
Dim x As String
Dim z As String
Dim w As String
Dim rcell As Range
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Range("A2").Select
Do Until ActiveCell.Value = ""
If ActiveCell.offset(1).Value = ActiveCell.Value Then
w = ActiveCell.offset(, 2)
z = ActiveCell.Value
y = ActiveCell.offset(, 1) & " & "
Do Until ActiveCell.offset(1).Value <> ActiveCell.Value
ActiveCell.offset(1).Select
x = ActiveCell.offset(, 1) & " & "
y = y & x
Loop
Range("F" & Rows.count).End(3)(2) = w
Range("E" & Rows.count).End(3)(2) = y
Range("D" & Rows.count).End(3)(2) = z
Range("E" & Rows.count).End(3) = Left(Range("E" & Rows.count).End(3), Len(Range("E" & Rows.count).End(3)) - 2)
Else
ActiveCell.offset(1).Select
End If
Loop
For Each rcell In Range("E2:E" & Range("A" & Rows.count).End(3).row)
If Not rcell Like "*APPLE*" Then Range(rcell.offset(, -1), rcell.offset(, 1)).Delete xlUp
Next rcell
For Each rcell In Range("E2:E" & Range("A" & Rows.count).End(3).row)
If Not rcell Like "*PEAR*" Then Range(rcell.offset(, -1), rcell.offset(, 1)).Delete xlUp
Next rcell
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Bookmarks