приход по 51

'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

Добавить комментарий

Ваш адрес email не будет опубликован.