Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("D5")) Is Nothing Then
    Application.EnableEvents = False
Dim FoundDate As Range
Dim Sh As Worksheet
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
 iLastRow = Cells(Rows.Count, "D").End(xlUp).Row + 1
 Range("D10:F" & iLastRow).ClearContents
  For Each Sh In Worksheets
    If Sh.Name <> "Лист2" Then
     With Sh
       Set FoundDate = .Rows(7).Find(Target, , xlFormulas, xlWhole)
       If Not FoundDate Is Nothing Then     'нашли соответствие
          iLR = .Range("B7").End(xlDown).Row
          For i = 8 To iLR
            If Not IsEmpty(.Cells(i, FoundDate.Column)) Then
             iLastRow = Cells(Rows.Count, "D").End(xlUp).Row + 1
             Cells(iLastRow, "D") = Sh.Name                                'имя листа
             .Cells(i, "B").Copy Cells(iLastRow, "E")                      'наименование
             .Cells(i, FoundDate.Column).Copy Cells(iLastRow, "F")         'количество
            End If
          Next
       End If
     End With
    End If
  Next
  End If
    Application.EnableEvents = True
End Sub