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