Sub t()
      Dim c As Range, lr&, dk As Object, dt As Object
      Dim w As Worksheet, i&, j&, a(), a1(), a2(), sk$, st$
      
      Set dk = CreateObject("scripting.dictionary")
      Set dt = CreateObject("scripting.dictionary")
      
      With ActiveSheet
          .UsedRange.MergeCells = False
          Set c = .[a:a].Find("Период (было)", lookat:=xlWhole)
          If c Is Nothing Then Exit Sub
          lr = .Cells(.Rows.Count, 1).End(xlUp).Row
          Set w = ThisWorkbook.Worksheets.Add
          .Outline.ShowLevels RowLevels:=1
          .Range(c.Offset(1), .Cells(lr, 1)).SpecialCells(xlCellTypeVisible).Copy w.[a1]
          a = w.[a1].CurrentRegion.Value
          For Each v In a: dk.Item(v) = 0: Next
          .Outline.ShowLevels RowLevels:=2
          .Range(c.Offset(1), .Cells(lr, 1)).SpecialCells(xlCellTypeVisible).Copy w.[a1]
          a = w.[a1].CurrentRegion.Value
          For Each v In a
              If Not dk.exists(v) Then dt.Item(v) = 0
          Next
          .Outline.ShowLevels RowLevels:=3
          Application.DisplayAlerts = False
              w.Delete
          Application.DisplayAlerts = True
          a1 = .Range(c.Offset(1), .Cells(lr, 7)).Value
          ReDim a2(1 To UBound(a1), 1 To 7)
          For i = 1 To UBound(a1)
              If dk.exists(a1(i, 1)) Then
                  sk = a1(i, 1)
              ElseIf dt.exists(a1(i, 1)) Then
                  st = a1(i, 1)
              Else
                  j = j + 1
                  a2(j, 1) = sk
                  a2(j, 2) = st
                  a2(j, 3) = a1(i, 1)
                  a2(j, 4) = a1(i, 4)
                  a2(j, 5) = a1(i, 5)
                  a2(j, 6) = a1(i, 6)
                  a2(j, 7) = a1(i, 7)
              End If
          Next
          .[m22].Resize(j, 7).Value = a2
      End With
End Sub