Sub OvoschiFrukti()

    Dim i As Integer, j As Integer
    Dim msg As String, sHeader As String
    
    With Sheet1

        For i =  2  To .Range("A2").End(xlToRight).Column

            ' Получаем название овоща/фрукта.
            sHeader = .Cells( 2 , i)

            For j =  3  To .Cells( 3 , i).End(xlDown).Row
                On Error Resume Next 'Если нет каментов
                If .Cells(j, i).Comment.Text = sHeader Then
                    msg = msg & .Cells( 1 , i) & " - " & .Cells(j, i) & vbNewLine
                End If
                On Error GoTo  0 
            Next

        Next

    End With
    
    MsgBox msg

End Sub

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
    Dim msg As String, sHeader As String
    
    If TypeName(Selection) <> "Range" Then
        MsgBox "Выделите ячейки!", vbCritical, "Ошибка"
        Exit Sub
    End If
    
    Set rng = Selection
    
    With rng.Columns( 1 ).Find(What:="Группа")
        iRowGroup = .Row
        iColGroup = .Column
    End With
    
    With rng.Columns( 1 ).Find(What:="Специфика")
        iRowSpec = .Row
        iColSpec = .Column
    End With
    
    Debug.Print iRowGroup, iColGroup, iRowSpec, iColSpec
    
    For i = iColSpec +  1  To Cells(iRowSpec, iColSpec).End(xlToRight).Column
        
        ' Получаем название фрукта/овоща.
        sHeader = Cells(iRowSpec, i)
        
        For j = iRowSpec +  1  To Cells(iRowSpec, i).End(xlDown).Row
            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 
        Next
    Next

    MsgBox msg

End Sub

    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