Neyse makrolu olan dosyayıda ekleyeyim.
Formüllü olan için denemek için
yazınca bile hata veriyor yani sorun değil denem yapmamdaki amaç MALZEME1,MALZEME 2 gibide koşula eklemekti.

Private Sub Worksheet_Change(ByVal Target As Range)



    Dim aranan1 As String, aranan2 As String

    Dim kacinci1 As Integer, kacinci2 As Integer

    Dim i As Integer

    Dim sonSutun As Integer

    Dim arr(), say As Integer

    Const satirNo As Byte = 17

    Const baslangicSutunNo As Byte = 6

    Const adres As String = "E16"

    Const adres2 As String = "F16"

    

    If Target.Address(0, 0) <> adres Then Exit Sub

        If Range(adres).Value = "" Then

            Range(Cells(satirNo, "F"), Cells(satirNo - 1, Columns.Count)).ClearContents

            Range(Cells(satirNo - 1, "F"), Cells(satirNo, Columns.Count)).Borders.LineStyle = xlNone

            Exit Sub

        End If



    sonSutun = Cells(15, Columns.Count).End(xlToLeft).Column

    If sonSutun < baslangicSutunNo Then Exit Sub

    For i = baslangicSutunNo To sonSutun

        aranan1 = Target.Offset(-1, i - (baslangicSutunNo - 1)).Value

        aranan2 = Target.Value

        On Error Resume Next

        kacinci1 = WorksheetFunction.Match(aranan1, Rows(3), 0)

        kacinci2 = WorksheetFunction.Match(aranan2, Columns(2), 0)

        If kacinci1 > 0 And kacinci2 > 0 Then

            say = say + 1

            ReDim Preserve arr(1 To 2, 1 To say)

            arr(1, say) = Cells(kacinci2, kacinci1).Value

            arr(2, say) = Cells(kacinci2 + 1, kacinci1).Value

        Else

            Cells(satirNo, i).Value = ""

        End If

        On Error GoTo 0

    Next

    If say > 0 Then

        Range(adres2).Resize(2, UBound(arr, 2)).Value = arr

        Range(adres2, Range(adres2).End(xlDown).End(xlToRight)).Borders.LineStyle = 1

    End If

    Erase arr

End Sub