Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("B1:D1")) Is Nothing Then
     Application.EnableEvents = False
Dim Sht As Worksheet
Dim iLastRow As Integer
Dim i As Integer
Dim iLR As Integer
  iLR = Cells(Rows.Count, 1).End(xlUp).Row + 1
  Range("A4:E" & iLR).Clear
   iLR = Cells(Rows.Count, 1).End(xlUp).Row + 1
    For Each Sht In Worksheets
      If Sht.Name <> "ОБЩ" Then
        With Sht
          iLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
          For i = 2 To iLastRow
           If IsDate(.Cells(i, "D")) Then
             If .Cells(i, "D") >= Range("B1") And .Cells(i, "D") <= Range("D1") Then
               .Range("B" & i & ":D" & i).Copy Cells(iLR, "B")
                 Cells(iLR, 1) = Sht.Name
               iLR = Cells(Rows.Count, "A").End(xlUp).Row + 1
             End If
           End If
           If IsDate(.Cells(i, "E")) Then
             If .Cells(i, "E") >= Range("B1") And .Cells(i, "E") <= Range("D1") Then
               .Range("B" & i & ":C" & i).Copy Cells(iLR, "B")
               .Range("E" & i).Copy Cells(iLR, "E")
                 Cells(iLR, 1) = Sht.Name
               iLR = Cells(Rows.Count, "A").End(xlUp).Row + 1
             End If
           End If
          Next
        End With
      End If
    Next
  End If
    Application.EnableEvents = True
End Sub