WTF?!!!!!!!!!!!!

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
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 = constsMonth
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