Сводная таблица + расчёт динамики по периодам

Sub ContactPivot()
    Dim i As Long, j As Long, r As Long, c As Long, k As Long
    Dim rng As Range, arr As Variant, n As Long, nMax As Long
    Set rng = Sheets(1).Cells.Find("Îáùàÿ òàáëèöà")
    Set rng = Sheets(1).Cells.Find("Íåäåëÿ", rng)
    Set rng = Sheets(1).Range(rng, rng.End(xlDown).End(xlToRight))
    arr = rng
    r = UBound(arr) - 2
    c = 2 * UBound(arr, 2) - 4
    ReDim h(0, c) As Variant
    For i = 0 To 2
        h(0, i) = arr(1, i + 1)
    Next i
    For i = 3 To c - 1 Step 2
        h(0, i) = arr(1, (i - 3) \ 2 + 4) & "_"
        h(0, i + 1) = "Ïðèðîñò " & arr(1, (i - 3) \ 2 + 4) & "_"
    Next i
    ReDim v(3 * r + 2, c) As Variant
    For k = 0 To 2
        For i = 0 To r
            n = Val(Split(arr(i + 2, 1))(0)) + k \ 2
            If n > nMax Then nMax = n
            v(i + k * (r + 1), 0) = n & " íåäåëÿ"
            For j = 1 To 2
                v(i + k * (r + 1), j) = arr(i + 2, j + 1)
            Next j
            For j = 3 To c - 1 Step 2
                v(i + k * (r + 1), j + Sgn(k)) = Sgn(3 - 2 * k) * arr(i + 2, (j - 3) \ 2 + 4)
            Next j
        Next i
    Next k
    Sheets.Add After:=Sheets(Sheets.Count)
    Range("A1").Resize(1, c + 1) = h
    Range("A2").Resize(3 * r + 3, c + 1) = v
    Set rng = ActiveSheet.UsedRange
    Sheets.Add Before:=Sheets(Sheets.Count)
    With ActiveWorkbook.PivotCaches.Create(xlDatabase, rng).CreatePivotTable(Range("A3"))
        For i = 0 To 1
            With .PivotFields(h(0, i))
                .Orientation = xlRowField
                .Position = i + 1
                .LayoutForm = xlTabular
            End With
        Next i
        For i = 3 To c
            .AddDataField .PivotFields(h(0, i)), Replace(h(0, i), "_", ""), xlSum
        Next i
        .PivotFields(h(0, 0)).PivotItems(nMax & " íåäåëÿ").Visible = False
        .ColumnGrand = False
    End With
    For i = 3 To c
        Columns(i).ColumnWidth = 15.3
        Cells(4, i).VerticalAlignment = xlTop
        Cells(4, i).WrapText = True
    Next i
End Sub