If TypeName(Selection) <> "Range" Then
        MsgBox "Âûäåëèòå ÿ÷åéêè!", vbCritical, "Îøèáêà"
        Exit Sub
    End If

Attribute VB_Name = "Module1"
Option Explicit

Sub OvoschiFrukti()

    Dim rng As Range
    Dim iRowGroup As Integer, iRowSpec As Integer
    Dim iColGroup As Integer, iColSpec As Integer
    Dim i As Integer, j As Integer, lastRow As Long
    Dim msg As String, sHeader As String
    
    If TypeName(Selection) <> "Range" Then
        MsgBox "Выделите ячейки!", vbCritical, "Ошибка"
        Exit Sub
    End If
    
    Set rng = Selection
    
    If rng.Cells( 1 ) <> "Группа" Then
        MsgBox "Выделен неверный диапазон!", vbCritical, "Ошибка"
        Exit Sub
    End If
    
    With rng.Columns( 1 ).Find(What:="Группа")
        iRowGroup = .Row
        iColGroup = .Column
    End With
    
    With rng.Columns( 1 ).Find(What:="Специфика")
        iRowSpec = .Row
        iColSpec = .Column
    End With
    
    lastRow = iRowGroup + rng.Rows.Count -  1 

    For i = iColSpec +  1  To Cells(iRowSpec, iColSpec).End(xlToRight).Column
        
        ' Получаем название фрукта/овоща.
        sHeader = Cells(iRowSpec, i)
        
        For j = iRowSpec +  1  To lastRow
            If (Not IsEmpty(Cells(j, i))) And (Not Cells(j, i).Comment Is Nothing) Then
                On Error Resume Next
                If Cells(j, i).Comment.Text Like "*" & sHeader & "*" Then
                    msg = msg & Cells(iRowGroup, i) & " - " & Cells(j, i) & vbNewLine
                End If
                On Error GoTo  0 
            End If
        Next
    Next

    MsgBox msg

End Sub