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