Sub tt()
Application.ScreenUpdating = False
Dim d
Dim arr
Dim x As Integer
Dim rng As Object, rngs As Object
Set rng = Sheets(4).Rows(2).Find([b1], , , xlWhole)
Set rngs = Sheets(4).Rows(2).Find([b2], , , xlWhole)
rngc = rng.Column
rngsc = rngs.Column
Set d = CreateObject("scripting.dictionary")
For i = 4 To Sheets.Count - 3
For y = 4 To 48
d(Sheets(2).Cells(y, 2).Value) = 0
Next
Sheets(i).Select
arr = Sheets(i).Range("j3:nx48")
For x = rngc To rngsc
If IsDate(Sheets(i).Cells(2, x)) = True Then
For y = 4 To 39
d(Sheets(2).Cells(y, 2).Value) = d(Sheets(2).Cells(y, 2).Value) + arr(y - 3, x - 9)
Next
For y = 40 To 40
d(Sheets(2).Cells(y, 2).Value) = arr(y - 3, rngc - 9)
Next
For y = 41 To 49
d(Sheets(2).Cells(y, 2).Value) = arr(y - 3, x - 9)
Next
End If
ThisWorkbook.Sheets(2).Cells(4, i - 1).Resize(d.Count) = Application.Transpose(d.items)
Next
Next
Sheets(2).Select
Set rng = Nothing
Set rngs = Nothing
Application.ScreenUpdating = True
End Sub
'srow = Sheets(i).UsedRange.Rows.Count