Option Explicit
Option Base 0

Private Enum saveloadparams
    Save
    Load
End Enum
Private Const constsCompany As String = "Êîìïàíèÿ"
Private Const constsSum As String = "Èòîã"
Private Const constsMonth As String = "Ìåñÿö"
Private Const constsTmpWsStartPattern As String = "tmpWsByNW"


Private Sub saveloadcontext(param As saveloadparams)
    Static showaler, scrupdat, enevents, pagebrek, statsbar As Boolean
    Static calculat As Variant
    If (param = Save) Then
        scrupdat = Application.ScreenUpdating
        calculat = Application.Calculation
        enevents = Application.EnableEvents
        pagebrek = ActiveSheet.DisplayPageBreaks
        statsbar = Application.DisplayStatusBar
        showaler = Application.DisplayAlerts
    Else
        Application.ScreenUpdating = scrupdat
        Application.Calculation = calculat
        Application.EnableEvents = enevents
        ActiveSheet.DisplayPageBreaks = pagebrek
        Application.DisplayStatusBar = statsbar
        Application.DisplayAlerts = showaler
    End If
End Sub

Public Sub increasePerfom(needAlerts As Boolean)
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False
    Application.DisplayStatusBar = False
    Application.DisplayAlerts = needAlerts
End Sub


Private Sub createTittle(ByVal tarSh As Worksheet)
    tarSh.Cells(1, 1) = constsCompany
    tarSh.Cells(1, 2) = constsSum
    tarSh.Cells(1, 3) = constsMonth
End Sub

Private Sub addTable(ByVal tarSh As Worksheet, ByVal srcSh As Worksheet)
    'tar - left top Cell of table
    'src - src ws
    Dim tar As Range
    Dim src As Range
    If (tarSh.UsedRange.Cells.Count <= 1) Then
        Set tar = tarSh.Cells(1, 1)
    Else
        Set tar = tarSh.Cells(1, 1).Offset(tarSh.Cells(1, 1).CurrentRegion.Rows.Count, 0)
    End If
    Set src = srcSh.Cells(1, 1).CurrentRegion
    Set src = Range(srcSh.Cells(2, 1), src.Cells(src.Rows.Count, src.Columns.Count))
    
    
    src.Copy tar
    Set tar = Range(tar.Offset(0, 2), tar.Offset(src.Rows.Count - 1, 2))
    tar.Value = DateValue("01." + srcSh.name)
End Sub

Private Function shExist(ByRef sName As String, Optional ByVal wb As Workbook = Nothing) As Boolean
    If (wb Is Nothing) Then Set wb = ThisWorkbook
    Dim wsSh As Worksheet
    On Error Resume Next
    Set wsSh = wb.Sheets(sName)
    shExist = Not wsSh Is Nothing
End Function

Private Function isMonthName(ByRef month As String) As Boolean
    Dim tmp As Variant
    tmp = Null
    On Error Resume Next
    tmp = DateValue("01." + month)
    isMonthName = Not IsNull(tmp)
End Function

Private Function getRnd(Optional ByVal l As Long = 0, Optional ByVal r As Long = 100000) As Long
    getRnd = l + Int(Rnd() * (r - l))
End Function

Private Function getTmpWs(Optional ByVal wb As Workbook = Nothing) As Worksheet
    If (wb Is Nothing) Then Set wb = ThisWorkbook
    Dim saved As Worksheet
    Set saved = wb.ActiveSheet
    Dim i As Long
    Dim name As String
    i = getRnd(0, 10000)
    Do
        i = i + 1
        name = constsTmpWsStartPattern + Trim(Str(i))
    Loop While (shExist(name))
    Set getTmpWs = wb.Sheets.Add(, wb.Sheets(wb.Sheets.Count))
    getTmpWs.name = name
    If ((Not saved Is Nothing) And (0 = StrComp(ActiveWorkbook.FullName, wb.FullName))) Then saved.Select
End Function

Private Function Min(ByVal l As Variant, ByVal r As Variant) As Variant
    If (l < r) Then
        Min = l
    Else
        Min = r
    End If
End Function

Private Function isTmpWs(ByVal ws As Worksheet) As Boolean
    Dim name As String
    name = ws.name
    name = Left(name, Min(Len(name), Len(constsTmpWsStartPattern)))
    isTmpWs = (StrComp(constsTmpWsStartPattern, name) = 0)
End Function

Private Sub DeleteWithoutAsking(ByRef obj As Variant)
    Dim b As Boolean
    b = Application.DisplayAlerts
    Application.DisplayAlerts = False
    obj.Delete
    Application.DisplayAlerts = b
End Sub

Private Sub saveWbAs(ByRef wb As Workbook, ByVal PATH As String, ByVal NAMEBEG As String)
    Dim tmpint As Long
    tmpint = 2
    Dim name As String
    name = NAMEBEG
    While (Dir(PATH & "\" & name & ".*") <> "")
        name = NAMEBEG + "_(" + Trim(Str(tmpint)) + ")"
        tmpint = tmpint + 1
    Wend
    wb.SaveAs PATH & "\" & name, , , , , , , xlUserResolution
End Sub

Private Function getNewWb(Optional ByVal sheetscnt As Integer = 1) As Workbook
    Dim tmpint As Integer
    tmpint = Application.SheetsInNewWorkbook
    Application.SheetsInNewWorkbook = sheetscnt
    Set getNewWb = Workbooks.Add()
    Application.SheetsInNewWorkbook = tmpint
End Function


Private Sub copypastesaveandclear(ByVal pvTable As PivotTable, ByVal newWb As Workbook, ByVal name As String)
    pvTable.TableRange1.Copy
    newWb.Sheets(1).Cells(1, 1).PasteSpecial xlPasteFormats
    newWb.Sheets(1).Cells(1, 1).PasteSpecial xlPasteValuesAndNumberFormats
    newWb.Sheets(1).UsedRange().Columns.AutoFit
    saveWbAs newWb, ThisWorkbook.PATH, name
    newWb.Sheets(1).UsedRange().Clear
End Sub


Private Sub main()
    saveloadcontext Save
    On Error GoTo finally
    increasePerfom True
    
    Dim tmpWs, tmpws2, pivWs As Worksheet
    Dim var As Variant
    Dim newWb As Workbook
    Set newWb = getNewWb()
    
    Set tmpWs = getTmpWs(ThisWorkbook)
    createTittle tmpWs
    For Each tmpws2 In ThisWorkbook.Sheets
        If ((tmpws2.Type = xlWorksheet) And (Not isTmpWs(tmpws2)) And isMonthName(tmpws2.name)) Then
            addTable tmpWs, tmpws2
        End If
    Next tmpws2
        
    Set pivWs = getTmpWs()
    Dim pvCashe As PivotCache
    Dim pvTable As PivotTable
    Dim pvDataField As PivotField
    Set pvCashe = ThisWorkbook.PivotCaches.Create(xlDatabase, tmpWs.Cells(1, 1).CurrentRegion.Address(True, True, xlR1C1, True))
    Set pvTable = pvCashe.CreatePivotTable(pivWs.Cells(1, 1).Address(True, True, xlR1C1, True))
    With pvTable.PivotFields(constsCompany)
        .Orientation = xlRowField
        .Position = 1
    End With
    With pvTable.PivotFields(constsMonth)
        .Orientation = xlColumnField
        .Position = 1
    End With
    Set pvDataField = pvTable.AddDataField(pvTable.PivotFields(constsSum), "Data", xlSum)
    pvTable.PivotFields(constsMonth).DataRange.Cells(1).Group Start:=True, End:=True, Periods:=Array(False, False, False, _
        False, False, True, False)
    pvTable.CompactLayoutColumnHeader = ""
    pvTable.CompactLayoutRowHeader = ""
    copypastesaveandclear pvTable, newWb, "Rewsult1"
    
    pvDataField.Calculation = xlPercentOfTotal
    copypastesaveandclear pvTable, newWb, "Rewsult2"
    
    
    pvTable.PivotFields(constsMonth).DataRange.Cells(1).Group Start:=True, End:=True, Periods:=Array(False, False, False, _
        False, True, False, False)
    With pvDataField
        .Calculation = xlRunningTotal
        .BaseField = "Ìåñÿö"
    End With
    pvTable.RowGrand = False
    copypastesaveandclear pvTable, newWb, "Rewsult3"
     
    With pvDataField
        .Calculation = xlDifferenceFrom
        .BaseField = constsCompany
        .BaseItem = "Ðàêóøêà"
    End With
    pvTable.RowGrand = True
    copypastesaveandclear pvTable, newWb, "Rewsult4"
    DeleteWithoutAsking tmpWs
    DeleteWithoutAsking pivWs
    newWb.Close False
finally:
    saveloadcontext Load
End Sub