```
Private Sub Worksheet_Change(ByVal Target As Range)
Dim a As Variant, b As Variant
Dim SheetList As Range, cell As Range
Dim i As Long, j As Long, k As Long, oset As Long
Dim SearchDate As Date
If Not Intersect(Target, Range("B3")) Is Nothing Then
Application.EnableEvents = False
ActiveSheet.UsedRange.Offset(4).ClearContents
If IsDate(Range("B3").Value) Then
SearchDate = Range("B3").Value
With Sheets("Lookup_Sheets")
Set SheetList = .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
End With
For Each cell In SheetList
With Sheets(cell.Value)
k = 0
a = .Range("I2", .Range("I" & .Rows.Count).End(xlUp).Offset(1)).Resize(, 8).Value '***
ReDim b(1 To UBound(a, 1), 1 To 8) '***
For i = 1 To UBound(a)
If a(i, 1) = SearchDate Then
k = k + 1
'***
For j = 1 To 8
Select Case j
Case Is < 3: oset = 3
Case Is < 6: oset = -2
Case Else: oset = 0
End Select
b(k, j) = a(i, j + oset)
Next j
'***
End If
Next i
End With
If k > 0 Then Me.Range("B" & Rows.Count).End(xlUp).Offset(1).Resize(k, 8).Value = b '***
Next cell
End If
Application.EnableEvents = True
End If
End Sub
```