'Option Explicit
''Возможные варианты: ДебетН, КредитН, ДебетО, КредитО, ДебетК, КредитК
Sub main()
' Удаление существующего листа сводной таблицы
Dim Sname As String
Sname = "Приходы"
Call delSheet(Sname)
Dim arr0() As String
Dim arr() As String
Dim arr1() As String
Dim arr2() As String
Dim arr3() As String
Dim arr4() As String
Dim arr5() As String 'Контрагенты
ReDim arr0(1) 'Приход по всем счетам
arr0(0) = "*"
ReDim arr(3) 'Чистый приход
arr(0) = "62*"
arr(1) = "76*"
arr(2) = "57*"
ReDim arr1(6) 'Займы
arr1(0) = "50.01"
arr1(1) = "66.03"
arr1(2) = "66.04"
arr1(3) = "67.03"
arr1(4) = "67.04"
arr1(5) = "58.03"
ReDim arr4(4) 'Кредиты
arr4(0) = "66.01"
arr4(1) = "67.01"
arr4(2) = "66.02"
arr4(3) = "67.02"
ReDim arr2(1) 'Возвраты
arr2(0) = "60*"
ReDim arr3(1) 'Переводы собственных средств
arr3(0) = "51*"
ReDim arr5(1) 'Переводы собственных средств
arr5(0) = "Контрагент"
Interval = 4
Call UPT("Общая ОСВ", Sname, "B5", "A" & Geti22(Sname, "Общий итог", 1) + Interval, "SvodT1", "СуммаД", "СчетК", arr0, "Дата")
Range("A" & Geti22(Sname, "Сумма по полю СуммаД", 1) - 1) = "Приход по всем счетам"
Call fill(Geti22(Sname, "Сумма по полю СуммаД", 1))
Call UPT("Общая ОСВ", Sname, "B5", "A" & Geti22(Sname, "Общий итог", i) + Interval, "SvodT2", "СуммаД", "СчетК", arr, "Дата")
Range("A" & Geti22(Sname, "Сумма по полю СуммаД", 1) - 1) = "Чистый приход"
Call fill(Geti22(Sname, "Сумма по полю СуммаД", 1))
Call UPT("Общая ОСВ", Sname, "B5", "A" & Geti22(Sname, "Общий итог", i) + Interval + 1, "SvodT9", "СуммаД", "Дата", arr, "Банк")
Range("A" & Geti22(Sname, "Сумма по полю СуммаД", 1) - 1) = "Чистые приходы по банкам"
Call fill(Geti22(Sname, "Сумма по полю СуммаД", 1))
Call UPT("Общая ОСВ", Sname, "B5", "A" & Geti22(Sname, "Общий итог", i) + Interval, "SvodT3", "СуммаД", "СчетК", arr1, "Дата")
Range("A" & Geti22(Sname, "Сумма по полю СуммаД", 1) - 1) = "Займы"
Call fill(Geti22(Sname, "Сумма по полю СуммаД", 1))
Call UPT("Общая ОСВ", Sname, "B5", "A" & Geti22(Sname, "Общий итог", i) + Interval, "SvodT4", "СуммаД", "СчетК", arr4, "Дата")
Range("A" & Geti22(Sname, "Сумма по полю СуммаД", 1) - 1) = "Кредиты"
Call fill(Geti22(Sname, "Сумма по полю СуммаД", 1))
Call UPT("Общая ОСВ", Sname, "B5", "A" & Geti22(Sname, "Общий итог", i) + Interval, "SvodT5", "СуммаД", "СчетК", arr2, "Дата")
Range("A" & Geti22(Sname, "Сумма по полю СуммаД", 1) - 1) = "Возвраты"
Call fill(Geti22(Sname, "Сумма по полю СуммаД", 1))
Call UPT("Общая ОСВ", Sname, "B5", "A" & Geti22(Sname, "Общий итог", i) + Interval, "SvodT6", "СуммаД", "СчетК", arr3, "Дата")
Range("A" & Geti22(Sname, "Сумма по полю СуммаД", 1) - 1) = "Переводы собственных средств"
Call fill(Geti22(Sname, "Сумма по полю СуммаД", 1))
Call UPT("Общая ОСВ", Sname, "B5", "A" & Geti22(Sname, "Общий итог", i) + Interval, "SvodT7", "СуммаД", "Контрагент", arr5, "Дата")
Range("A" & Geti22(Sname, "Сумма по полю СуммаД", 1) - 1) = "Контрагент (приходы)"
Call fill(Geti22(Sname, "Сумма по полю СуммаД", 1))
Call UPT("Общая ОСВ", Sname, "B5", "A" & Geti22(Sname, "Общий итог", i) + Interval, "SvodT8", "СуммаК", "Контрагент", arr5, "Дата")
Range("A" & Geti22(Sname, "Сумма по полю СуммаК", 1) - 1) = "Контрагент (расходы)"
Call fill(Geti22(Sname, "Сумма по полю СуммаК", 1))
End Sub
Sub UPT(SourseList As String, _
PVTList As String, _
FirstRangeSL As String, _
SecondRange As String, _
TableName1 As String, _
SummaPo As String, _
SortBy As String, _
ByRef arr() As String, _
SortByData As String)
Dim PTcache As PivotCache
Dim pt As PivotTable
Dim PItem As PivotItem
Dim Sname As String
Sname = PVTList '"Общая ОСВ"
Application.ScreenUpdating = False
' Создание кеэша сводной таблицы
ActiveWorkbook.PivotCaches.Create( _
SourceType:=xlDatabase, _
SourceData:=ThisWorkbook.Sheets(SourseList).Range(FirstRangeSL).CurrentRegion.Address, _
Version:=xlPivotTableVersion10).CreatePivotTable _
TableDestination:=ThisWorkbook.Sheets(Sname).Range(SecondRange), TableName:=TableName1, _
DefaultVersion:=xlPivotTableVersion10
ActiveSheet.PivotTables(TableName1).AddDataField ActiveSheet.PivotTables( _
TableName1).PivotFields(SummaPo), "Сумма по полю " & SummaPo, xlSum
Set pt = ActiveSheet.PivotTables(TableName1)
With pt
If SortByData = "Банк" Then
.PivotFields("СчетК").Orientation = xlPageField
End If
'Добавление полей
.PivotFields(SortBy).Orientation = xlRowField
.PivotFields(SortByData).Orientation = xlColumnField
.DataBodyRange.NumberFormat = "#,##0_ ;[Red]-#,##0 "
.DataBodyRange.ColumnWidth = 13
.DataBodyRange.Sort
End With
'Сортировка по убыванию
i = Geti2(Sname, "Общий итог")
j = Getj2(Sname, "Общий итог")
If SortBy = "Контрагент" Then
ActiveSheet.PivotTables(TableName1).PivotFields("Контрагент").AutoSort _
xlDescending, "Сумма по полю " & SummaPo, ActiveSheet.PivotTables(TableName1). _
PivotColumnAxis.PivotLines(j - 1), 1
Exit Sub
End If
If SortBy = "Дата" Then
'----------------------
On Error GoTo ErrorHandler0
With ActiveSheet.PivotTables(TableName1).PivotFields("СчетК") 'pt.PageFields("ОСВ.00")
For Each PItem In .PivotItems
Debug.Print PItem.Name
For i0 = 0 To UBound(arr, 1) - 1
PItem.Visible = Falce
If PItem.Name Like arr(i0) Then
PItem.Visible = True
Exit For
End If
Next i0
Next
End With
ActiveSheet.PivotTables("SvodT9").PivotFields("Дата").AutoSort xlAscending, _
"Дата"
GoTo Ends0:
ErrorHandler0:
PItem.Visible = True
Ends0:
'----------------------
Exit Sub
End If
On Error GoTo ErrorHandler
With ActiveSheet.PivotTables(TableName1).PivotFields(SortBy) 'pt.PageFields("ОСВ.00")
For Each PItem In .PivotItems
Debug.Print PItem.Name
For i0 = 0 To UBound(arr, 1) - 1
PItem.Visible = Falce
If PItem.Name Like arr(i0) Then
PItem.Visible = True
Exit For
End If
Next i0
Next
End With
GoTo Ends:
ErrorHandler:
' S1 = Geti22(Sname, "Сумма по полю СуммаД", 1) - 2
' S2 = Geti22(Sname, "Общий итог", i)
' Range(S1 & ":" & S2).Delete
PItem.Visible = True
Ends:
End Sub
Function GetERR(TableName1 As String) As String
GetERR = TableName1
End Function
Function Geti22(SheetName As String, KeyName As String, ByVal starti As Integer) As Integer
On Error Resume Next
Dim t As Boolean
t = False
ei = ThisWorkbook.Sheets(SheetName).Cells.SpecialCells(xlLastCell).Row
ej = ThisWorkbook.Sheets(SheetName).Cells.SpecialCells(xlLastCell).Column
For i = starti To ei
For j = 1 To ej
If LCase(Trim(ThisWorkbook.Sheets(SheetName).Cells(i, j).Value)) = LCase(KeyName) And t = False Then
t = True
End If
If LCase(Trim(ThisWorkbook.Sheets(SheetName).Cells(i, j).Value)) = LCase(KeyName) And t = True Then
Geti22 = i
t = False
End If
Next j
Next i
End Function
Sub fill(i As Integer)
Range(i - 1 & ":" & i - 1).Font.Bold = True
With Range(i - 1 & ":" & i - 1).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent3
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
End Sub
Sub delSheet(Sname As String)
Application.ScreenUpdating = False
' Удаление существующего листа сводной таблицы
On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Sheets(Sname).Delete
On Error GoTo 0
Worksheets.Add
ActiveSheet.Name = Sname
ActiveWindow.DisplayGridlines = False
ThisWorkbook.Sheets(Sname).Select
End Sub
Sub CheckForFile()
Dim FileName As String
Dim x As Workbook
FileName = "BUDGET.XLSX"
On Error Resume Next
Set x = Workbooks(FileName)
If err = 0 Then
MsgBox FileName & " is open."
Else
MsgBox FileName & "is not open."
End If
On Error GoTo 0
End Sub
Function Geti2(SheetName As String, Optional KeyName As String) As Integer
On Error Resume Next
Dim t As Boolean
t = True
If Len(KeyName) = 0 Then
KeyName = "Код"
End If
ei = ThisWorkbook.Sheets(SheetName).Cells.SpecialCells(xlLastCell).Row
ej = ThisWorkbook.Sheets(SheetName).Cells.SpecialCells(xlLastCell).Column
For i = 1 To ei
For j = 1 To ej
If LCase(Trim(ThisWorkbook.Sheets(SheetName).Cells(i, j).Value)) = LCase(KeyName) And t = True Then
Geti2 = i
t = False
End If
Next j
Next i
End Function
Function Getj2(SheetName As String, Optional KeyName As String) As Integer
On Error Resume Next
Dim t As Boolean
t = True
If Len(KeyName) = 0 Then
KeyName = "Код"
End If
ei = ThisWorkbook.Sheets(SheetName).Cells.SpecialCells(xlLastCell).Row
ej = ThisWorkbook.Sheets(SheetName).Cells.SpecialCells(xlLastCell).Column
For i = 1 To ei
For j = 1 To ej
If LCase(Trim(ThisWorkbook.Sheets(SheetName).Cells(i, j).Value)) = LCase(KeyName) And t = True Then
Getj2 = j
t = False
End If
Next j
Next i
End Function