Sub t()
  Dim a(), wData As Worksheet, w1 As Worksheet, w2 As Worksheet
  Dim dm As Object, i&, df As Object, d As Object, s$, e, sDate$, ii&, j&, ee, jj&
  Set dm = CreateObject("scripting.dictionary")
  Set df = CreateObject("scripting.dictionary")
  With ThisWorkbook
    Set wData = .Sheets("Data")
    With wData
      a = .Range(.[a2], .Cells(wData.Rows.Count, 1).End(xlUp)).Resize(, 7).Value
      sDate = Format(.[f2], "mmmm yyyy")
    End With
    For i = 1 To UBound(a)
      s = a(i, 3) & "|" & a(i, 2) & "|" & a(i, 5) & "|" & a(i, 7)
      If Not df.exists(a(i, 1)) Then df(a(i, 1)) = df.Count + 1
      If dm.exists(s) Then Set d = dm(s) Else Set d = CreateObject("scripting.dictionary")
      d(a(i, 6) & "|" & a(i, 4) & "|" & df(a(i, 1))) = 0&
      Set dm(s) = d
    Next
    
    On Error Resume Next
    Application.DisplayAlerts = False
    .Worksheets("w1").Delete
    .Worksheets("w2").Delete
    Application.DisplayAlerts = False
    On Error GoTo 0
    
    With .Worksheets.Add
      .Name = "w1": i = 1
      For Each e In dm.keys
        i = i + 1
        .Cells(i, 1) = i - 1
        .Cells(i, 2).Resize(, 4).Value = Split(e, "|")
      Next
    End With
    With .Worksheets.Add
      .Name = "w2": .[c2] = sDate: i = 4: ii = 1
      For Each e In dm.keys
        .Cells(i, 1) = ii
        .Cells(i, 3) = Split(e, "|")(0)
        .Cells(i, 9) = Split(e, "|")(2)
        .Cells(i, 13) = Split(e, "|")(1)
        Set d = dm(e): jj = i + 3
        For Each ee In df.keys
          .Cells(jj, 2) = ee
          .Cells(jj, 1) = df(ee)
          jj = jj + 1
        Next
        For Each ee In d.keys
          .Cells(--Split(ee, "|")(2) + i + 2, Day(Split(ee, "|")(0)) + 2) = CInt(Split(ee, "|")(1))
        Next
        i = i + df.Count + 4: ii = ii + 1
      Next
    End With
  End With
End Sub