Attribute VB_Name = "SVOD"
Option Explicit
Public pnODBC, pnLogin, pnParol, pnUser, _
        pnwrkODBC, pnwrkConnect, pndbNameSql, pnAddress_Row, pnAddress_Col

Sub Server_Connect()

On Error GoTo doError

	'EdiS 25.09.2008 A22=1 - Win, A22<>1 - sql
	if (Application.ActiveWorkbook.Sheets("Service").Range("A22") = 1)  then
		set pnwrkODBC    = CreateWorkspace("SQL","","", dbUseODBC)
		set pnwrkConnect = pnwrkODBC.OpenConnection("",0,,"ODBC;DRIVER=SQL Server;SERVER=" + pnODBC + ";DATABASE=" + pndbNameSql + ";")
	else
		set pnwrkODBC    = DAO.CreateWorkspace("SQL",pnLogin, decode_psw(pnParol), dbUseODBC)
		set pnwrkConnect = pnwrkODBC.OpenConnection("SQL_CONNECT",0, ,"ODBC;DRIVER={SQL Server};SERVER=" + pnODBC + ";DATABASE=" + pndbNameSql + ";UID=" + pnLogin + ";PWD=" + decode_psw(pnParol) + ";DSN=")
	end

Exit Sub
doError:
    'Call ERROR_EVENT("Server_Connect")
End Sub

Sub doSvod()
Dim sheetsService As Object, sheetsReport As Object, sheet, sheetsSQLDATA2 As Object
Dim KRIT_RAZDEL_COLUMNCOUNT As Long, KRIT_RAZDEL_COLUMN As Long, KRIT_RAZDEL_ROW As Long
Dim newBook, bookName, nameRep, wrkCount, sqlStr, wrkResultSet, bookRep, i, j
Dim codeArr() As String, linkArr() As Integer, nameArr() As String, lineCount As Long, codeCol As Integer, razdStr As String
Dim lnk, repRowFirst As Integer, repRowLast As Integer, sheetRow As Integer
Dim cdep, div, dep, tgt, exp, sum, row, add_field, oldRow, lnDevide, oldGraf, summa() As Double, nameCol As Integer
Dim oldDep As String, row11, col11, aaa As Integer
Dim str_status() As Integer, orderStr As String, flag800000 As Boolean, add_field1

If Not testRef Then Exit Sub
'myError
Set sheetsService = Sheets("Service")
Set sheetsSQLDATA2 = Sheets("SQLDATA2")
row11 = sheetsService.Range("KRIT_GRAF").row
col11 = sheetsService.Range("KRIT_GRAF").column

pnODBC = VBA.Trim(sheetsService.Range("A3").value)  'DAtaSource
pnLogin = VBA.Trim(sheetsService.Range("A5").value) 'Login
pnParol = VBA.Trim(sheetsService.Range("A6").value) 'Parol
pndbNameSql = VBA.Trim(sheetsService.Range("A4").value) 'Name DB SQL

With Sheets("Service")
    KRIT_RAZDEL_COLUMNCOUNT = .Range("KRIT_RAZDEL").Columns.count
    KRIT_RAZDEL_COLUMN = .Range("KRIT_RAZDEL").column
    KRIT_RAZDEL_ROW = .Range("KRIT_RAZDEL").row
End With
lnDevide = sheetsService.Range("A29").value

'nameRep = Application.ActiveWorkbook.Name
'Set bookRep = Application.ActiveWorkbook
'Set newBook = Workbooks.Add
'bookName = newBook.Name
'bookRep.Activate
'Stop
'SQL-запрос

' формируем строку для сортировки
orderStr = ""
If sheetsService.Range("B60").Text <> "" Then
   i = 15
   oldDep = sheetsService.Range("B60").Text
   razdStr = getNextSubstr(oldDep, "[")
   While oldDep <> ""
        razdStr = getNextSubstr(oldDep, "[")
        orderStr = orderStr + VBA.str(i) + ","
        i = i + 1
   Wend
End If
    Call Server_Connect
    sqlStr = "select [CORR_INN]=(select INN from s_corr where link=r.corr_in), " + _
            "[CORR_NAME]=(select SNAME from s_corr where link=r.corr_in), " + _
            "[DIVISION]=(select code from s_kbk where link= raf.division), " + _
            "[DEPARTMENT]=(select code from s_kbk where link= raf.department), " + _
            "[TARGET_ITEM]=(select code from s_kbk where link= raf.target_item), " + _
            "[EXPEND]=(select code from s_kbk where link= raf.expend), " + _
            "[ITEM]=(select code from report_str RS where RS.BAR = RV.BARS AND RS.RAZDEL = RV.OBJECT AND RS.OBJECT = (select link from s_objects where code=''" + Replace_in_Str(Replace_in_Str(VBA.Trim(Sheets("Service").Range("A15")), "_SVOD", ""), "_F7", "_F6") + "'')), " + _
            "[INCOME]=(select code from s_kbk where link= raf.income), " + _
            "[ADD_BK]=(select code from s_kbk where link= raf.add_bk), " + _
            "[BAR]=rv.bars, " + _
            "[GRAF]=rv.grafs, " + _
            "[VALUE]=CONVERT(money,rv.value/" + VBA.str(lnDevide) + "), " + _
            "[OBJECT]=rv.object, " + _
            "[cDEPARTMENT]=(select Name from s_kbk where link= raf.department) " + _
            sheetsService.Range("B60").Text + _
            "from reports r, report_values rv ,report_add_fields raf " + _
            "where  r.date_begin=''" + VBA.Trim(Sheets("Service").Range("A18").Text) + "'' and r.date_end=''" + VBA.Trim(Sheets("Service").Range("A19").Text) + "'' and r.object in(select link from s_objects where code=''" + VBA.Trim(Sheets("Service").Range("A15")) + "'') and " + _
            "       r.link=rv.link_up and r.corr_in=" + VBA.Trim(sheetsService.Range("A16")) + " and r.link=raf.link_up and rv.value<>0 " + _
            "order by object,corr_inn, " + orderStr + " 4, 3, 5, 6, 7, bar,graf "
   
    ' выполнение
    Set wrkResultSet = pnwrkConnect.OpenRecordset("EXECUTE A_EXEC ' " + sqlStr + " '", dbOpenDynaset)
    ' получим LINK  объекта
    If wrkResultSet.EOF = False Then ' данные есть
            ' заполнение таблицы с данными
            wrkCount = 0
            While Not wrkResultSet.EOF
                If wrkCount <> 0 Then wrkResultSet.MoveNext

                Sheets("SQLDATA2").Cells(1 + wrkCount * 200, 1).CopyFromRecordset wrkResultSet, 200, wrkResultSet.Fields.count
                wrkCount = wrkCount + 1
            Wend
            'Sheets("SQLDATA2").Cells(wrkResultSet.RecordCount + 1, 1) = ""
    Else
            MsgBox ("Нет данных для свода !")
            Exit Sub
    End If
    Set wrkResultSet = Nothing

'чистим критерий
With sheetsService
    .Range(.Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN), .Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN + KRIT_RAZDEL_COLUMNCOUNT - 1)) = ""
End With

If (sheetsService.Range("A15") = "DOCUMENTS_F614") Or (sheetsService.Range("A15") = "DOCUMENTS_F714") Or (sheetsService.Range("A15") = "DOCUMENTS_SVOD_F614") Or (sheetsService.Range("A15") = "DOCUMENTS_SVOD_F714") Or (sheetsService.Range("A15") = "DOCUMENTS_0503055") Or (sheetsService.Range("A15") = "DOCUMENTS_SVOD_0503055") Or (sheetsService.Range("A15") = "DOCUMENTS_F613") Or (sheetsService.Range("A15") = "DOCUMENTS_SVOD_F613")  Or (sheetsService.Range("A15") = "DOCUMENTS_F713") Or (sheetsService.Range("A15") = "DOCUMENTS_SVOD_F713") Then
     flag800000 = False
Else
     flag800000 = True
End If

'основной цикл
'Stop
row = 1
For i = 1 To sheetsService.Range("B23")
    'добавим лист в новую книгу
    'Set sheet = newBook.Sheets.Add
    sheetsService.Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN) = i
    sheetsService.Cells(KRIT_RAZDEL_ROW + 3, KRIT_RAZDEL_COLUMN).CALCULATE
    'sheet.Name = sheetsService.Cells(KRIT_RAZDEL_ROW + 3, KRIT_RAZDEL_COLUMN)
    
    razdStr = VBA.Trim(VBA.str(i))
    Set sheetsReport = Sheets(VBA.Trim(sheetsService.Cells(KRIT_RAZDEL_ROW + 3, KRIT_RAZDEL_COLUMN)))
    sheetsReport.Activate

    ' защита листа снимаем
    sheetsReport.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False

    ReDim str_status(sheetsService.Range("A10"))
    
    For j = 1 To sheetsService.Range("A10").value
    'критерий для колонок с данными
        sheetsService.Cells(row11 + 1, col11) = j
        sheetsService.Cells(row11 + 1, col11 + 1) = ""
        str_status(j) = sheetsService.Cells(row11 + 4, col11).value
    Next


    ReDim summa(sheetsService.Range("A10") + 1)
    For j = 1 To sheetsService.Range("A10")
        summa(j) = 0
    Next
    repRowFirst = sheetsReport.Range("TITLE_" + razdStr).Rows.count + 1
    repRowLast = sheetsReport.Range("FOOTER_" + razdStr).row - 1
    
    If exists_name("DIVISION_" + razdStr) Then
        div = sheetsReport.Range("DIVISION_" + razdStr).column
    Else
        div = 0
    End If
    If exists_name("DEPARTMENT_" + razdStr) Then
        dep = sheetsReport.Range("DEPARTMENT_" + razdStr).column
    Else
        dep = 0
    End If
    If exists_name("cDEPARTMENT_" + razdStr) Then
        cdep = sheetsReport.Range("cDEPARTMENT_" + razdStr).column
    Else
        cdep = 0
    End If
    If exists_name("TARGETITEM_" + razdStr) Then
        tgt = sheetsReport.Range("TARGETITEM_" + razdStr).column
    Else
        tgt = 0
    End If
    If exists_name("EXPEND_" + razdStr) Then
        exp = sheetsReport.Range("EXPEND_" + razdStr).column
    Else
        exp = 0
    End If
    If exists_name("ADD_FIELD_" + razdStr) Then
        add_field = sheetsReport.Range("ADD_FIELD_" + razdStr).column
    Else
        add_field = 0
    End If
    If exists_name("ADD_FIELD1_" + razdStr) Then
        add_field1 = sheetsReport.Range("ADD_FIELD1_" + razdStr).column
    Else
        add_field1 = 0
    End If
    sum = sheetsReport.Range("MAIN_DATA_" + razdStr).column
    
    'sheetsReport.Range("TITLE_" + razdStr).Copy Destination:=newBook.Sheets(sheet.Name).Range("A1")
    lineCount = repRowLast - repRowFirst + 1
    ReDim codeArr(lineCount)
    ReDim linkArr(lineCount)
    If sheetsService.Range("E5") <> 0 Then
        ReDim nameArr(lineCount)
        nameCol = sheetsService.Range("C6") - sheetsService.Range("E5")
    Else
        nameCol = 0
    End If
    codeCol = sheetsReport.Range("CODE_STR_" + razdStr).column
    For j = 1 To lineCount
        lnk = sheetsReport.Cells(j - 1 + repRowFirst, 1).value
        If lnk <> 0 Then
            codeArr(j) = VBA.Trim(sheetsReport.Cells(j - 1 + repRowFirst, codeCol))
            linkArr(j) = VBA.Trim(sheetsReport.Cells(j - 1 + repRowFirst, 1)) 'j - 1 + sheetsService.Range("C5")
            If nameCol <> 0 Then nameArr(j) = VBA.Trim(sheetsReport.Cells(j - 1 + repRowFirst, nameCol))
        End If
    Next
    
    ' защита листа снимаем
    sheetsReport.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
'    Stop
    If repRowFirst <> repRowLast Then sheetsReport.Rows(VBA.Trim(VBA.str(repRowFirst + 1)) + ":" + VBA.Trim(VBA.str(repRowLast))).Delete
    sheetRow = repRowFirst
    oldRow = 0
    oldGraf = 0
    oldDep = ""
    Do While IIf(Sheets("Service").Range("B23") > 1, sheetsSQLDATA2.Cells(row, 13) = i, sheetsSQLDATA2.Cells(row, 13) <> "")
        
        If (oldRow <> sheetsSQLDATA2.Cells(row, 10)) Or ((oldRow = sheetsSQLDATA2.Cells(row, 10)) And (oldGraf = sheetsSQLDATA2.Cells(row, 11))) Or (VBA.Trim(sheetsSQLDATA2.Cells(row, 4)) <> oldDep) Then 'codeArr(1) = "" And
            sheetRow = sheetRow + 1
'Stop
            sheetsReport.Rows(sheetRow).Insert
            For aaa = sheetsService.Range("C6") To sheetsService.Range("C6") + sheetsService.Range("A10") - 1
                sheetsReport.Cells(sheetRow, aaa) = 0
            Next

'            sheetsReport.Cells(sheetRow, 3).Borders(xlEdgeLeft).LineStyle = xlContinuous
'            sheetsReport.Cells(sheetRow, 3).Borders(xlEdgeLeft).Weight = xlMedium
            oldRow = sheetsSQLDATA2.Cells(row, 10)
            oldGraf = sheetsSQLDATA2.Cells(row, 11)
            oldDep = sheetsSQLDATA2.Cells(row, 4)
            
            If div <> 0 Then sheetsReport.Cells(sheetRow, div) = sheetsSQLDATA2.Cells(row, 3).Text
            If dep <> 0 Then sheetsReport.Cells(sheetRow, dep) = sheetsSQLDATA2.Cells(row, 4).Text
            If tgt <> 0 Then sheetsReport.Cells(sheetRow, tgt) = sheetsSQLDATA2.Cells(row, 5).Text
            If exp <> 0 Then sheetsReport.Cells(sheetRow, exp) = sheetsSQLDATA2.Cells(row, 6).Text
            If add_field <> 0 Then sheetsReport.Cells(sheetRow, add_field) = sheetsSQLDATA2.Cells(row, 15).Text
            If add_field1 <> 0 Then sheetsReport.Cells(sheetRow, add_field1) = sheetsSQLDATA2.Cells(row, 16).Text
            If cdep <> 0 Then
                sheetsReport.Cells(sheetRow, cdep) = sheetsSQLDATA2.Cells(row, 14).Text
                sheetsReport.Cells(sheetRow, cdep).Rows.AutoFit
            End If
        End If
       
        sheetsReport.Cells(sheetRow, sum + sheetsSQLDATA2.Cells(row, 11) - 1) = sheetsSQLDATA2.Cells(row, 12).value
        
       
'       If sheetsReport.Cells(sheetRow, codeCol) = "" Then
'stop
            For j = 1 To lineCount
                lnk = sheetsSQLDATA2.Cells(row, 10)
                If lnk = linkArr(j) Then
                    If codeArr(j) <> "" Then
                        sheetsReport.Cells(sheetRow, codeCol) = codeArr(j)
                        If nameCol <> 0 Then
                            sheetsReport.Cells(sheetRow, nameCol) = nameArr(j)
                            With sheetsReport.Cells(sheetRow, nameCol)
                                .Font.Bold = False
                                .HorizontalAlignment = xlLeft
                                .VerticalAlignment = xlBottom
                                .WrapText = True
                                .Orientation = 0
                                .IndentLevel = 0
                                .ShrinkToFit = True
                                .MergeCells = False
                            End With
                        End If
                    End If
                    GoTo www
                End If
            Next
'        End If
www:
         sheetsReport.Cells(sheetRow, codeCol).Rows.AutoFit
        
 '       With sheetsReport.Rows(sheetRow)
 '           .Font.Bold = False
 '           .HorizontalAlignment = xlLeft
 '           .VerticalAlignment = xlBottom
 '           .WrapText = True
 '           .Orientation = 0
 '           .IndentLevel = 0
 '           .ShrinkToFit = False
 '           .MergeCells = False
 '       End With
        
        If (codeArr(j) = "800000") Or (codeArr(j) = "8500000") Or (codeArr(j) = "8100000") Or (codeArr(1) = "" And lineCount = 1) Then
                'Stop
                If Not flag800000 Or (sheetsSQLDATA2.Cells(row, 4).Text = "998" And codeArr(j) = "8500000") Then
                        sheetsReport.Rows(sheetRow).RowHeight = 0
                End If
'                summa(1) = "ee"
'            debug.print summa(sheetsSQLDATA2.Cells(row, 11))
'            debug.print sheetsSQLDATA2.Cells(row, 12)
'            debug.print VBA.Val(sheetsSQLDATA2.Cells(row, 12))
            If str_status(sheetsSQLDATA2.Cells(row, 11)) = 0 And Not (sheetsSQLDATA2.Cells(row, 4).Text = "998" And codeArr(j) = "8500000") Then summa(sheetsSQLDATA2.Cells(row, 11)) = summa(sheetsSQLDATA2.Cells(row, 11)) + sheetsSQLDATA2.Cells(row, 12).value
        End If
        row = row + 1
    Loop
    If add_field1 <> 0 Or add_field1 <> 0 Or dep <> 0 Or div <> 0 Or tgt <> 0 Or exp <> 0 Then
       For j = 1 To sheetsService.Range("A10")
           If str_status(j) = 0 Then sheetsReport.Cells(sheetRow + 1, sheetsService.Range("C6") + j - 1) = summa(j)
       Next
    End If
    sheetsReport.Rows(repRowFirst).Delete

'    row = row + 1
    ActiveWindow.DisplayHeadings = True
    Call SetPageHeight
    Call SetLastRowsCount(11)
    ' защита листа снимаем
    sheetsReport.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
Next
    'проверим After_svod
    If VBA.Trim(sheetsService.Range("C38")) <> "" Then
        Call Application.Run(sheetsService.Range("C38").Text)
    End If

'CALL HideLists()
    On Error Resume Next
    Sheets("SQLData").Visible = xlVeryHidden
    Sheets("Service").Visible = xlVeryHidden
    Sheets("Form").Visible = xlVeryHidden
    Sheets("Alg").Visible = xlVeryHidden
    Sheets("Otbor_Cond").Visible = xlVeryHidden
    Sheets("SEEK_POP_SQLDATA").Visible = xlVeryHidden
    Sheets("SQLData1").Visible = xlVeryHidden
    Sheets("Контроль").Visible = xlVeryHidden
    Sheets("Расшифровка").Visible = xlVeryHidden
    Sheets("SQLDATA2").Visible = False
    On Error GoTo 0
sheetsService.Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN) = ""
pnUser = 1
Exit Sub
doError:
    'Call ERROR_EVENT("Server_Connect")
End Sub


Sub doSvodFull()
Dim sheetsService As Object, sheetsReport As Object, sheet, sheetsSQLDATA2 As Object
Dim KRIT_RAZDEL_COLUMNCOUNT As Long, KRIT_RAZDEL_COLUMN As Long, KRIT_RAZDEL_ROW As Long
Dim newBook, bookName, nameRep, wrkCount, sqlStr, wrkResultSet, bookRep, i, j
Dim codeArr() As String, linkArr() As Integer, lineCount As Long, codeCol As Integer, razdStr As String
Dim lnk, repRowFirst As Integer, repRowLast As Integer, sheetRow As Integer
Dim div, dep, tgt, exp, sum, row, oldRow, lnDevide, oldGraf
'myError
If Not testRef Then Exit Sub
Set sheetsService = Sheets("Service")
Set sheetsSQLDATA2 = Sheets("SQLDATA2")
pnODBC = VBA.Trim(sheetsService.Range("A3").value)  'DAtaSource
pnLogin = VBA.Trim(sheetsService.Range("A5").value) 'Login
pnParol = VBA.Trim(sheetsService.Range("A6").value) 'Parol
pndbNameSql = VBA.Trim(sheetsService.Range("A4").value) 'Name DB SQL

With Sheets("Service")
    KRIT_RAZDEL_COLUMNCOUNT = .Range("KRIT_RAZDEL").Columns.count
    KRIT_RAZDEL_COLUMN = .Range("KRIT_RAZDEL").column
    KRIT_RAZDEL_ROW = .Range("KRIT_RAZDEL").row
End With
lnDevide = sheetsService.Range("A29").value

'nameRep = Application.ActiveWorkbook.Name
'Set bookRep = Application.ActiveWorkbook
'Set newBook = Workbooks.Add
'bookName = newBook.Name
'bookRep.Activate

'stop
'SQL-запрос
    Call Server_Connect
    sqlStr = "select [CORR_INN]=''555'', " + _
            "[CORR_NAME]=''555'', " + _
            "[DIVISION]=(select code from s_kbk where link= raf.division), " + _
            "[DEPARTMENT]=(select code from s_kbk where link= raf.department), " + _
            "[TARGET_ITEM]=(select code from s_kbk where link= raf.target_item), " + _
            "[EXPEND]=(select code from s_kbk where link= raf.expend), " + _
            "[ITEM]=null, " + _
            "[INCOME]=null, " + _
            "[ADD_BK]=null, " + _
            "[BAR]=rv.bars, " + _
            "[GRAF]=rv.grafs, " + _
            "[VALUE]=rv.value/" + VBA.str(lnDevide) + ", " + _
            "[OBJECT]=rv.object " + _
            "from reports r, report_values rv ,report_add_fields raf " + _
            "where  r.date_begin=''" + VBA.Trim(Sheets("Service").Range("A18").Text) + "'' and r.date_end=''" + VBA.Trim(Sheets("Service").Range("A19").Text) + "'' and r.object in(select link from s_objects where code=''" + VBA.Trim(Sheets("Service").Range("A15")) + "'') and " + _
            "       r.link=rv.link_up and r.link=raf.link_up and r.CORR_IN = " + VBA.str(Sheets("Service").Range("A16")) + _
            "order by r.object, raf.DEPARTMENT, raf.DIVISION, raf.TARGET_ITEM, raf.EXPEND, rv.object,rv.bars,rv.grafs "
'            "group by r.object, raf.DIVISION, raf.DEPARTMENT, raf.TARGET_ITEM, raf.EXPEND, rv.object,rv.bars,rv.grafs "
    
    ' выполнение
    Set wrkResultSet = pnwrkConnect.OpenRecordset("EXECUTE A_EXEC ' " + sqlStr + " '", dbOpenDynaset)
    ' получим LINK  объекта
    If wrkResultSet.EOF = False Then ' данные есть
            ' заполнение таблицы с данными
            wrkCount = 0
            While Not wrkResultSet.EOF
                If wrkCount <> 0 Then wrkResultSet.MoveNext
                Sheets("SQLDATA2").Cells(1 + wrkCount * 200, 1).CopyFromRecordset wrkResultSet, 200, wrkResultSet.Fields.count
                wrkCount = wrkCount + 1
            Wend
            'Sheets("SQLDATA2").Cells(wrkResultSet.RecordCount + 1, 1) = ""
    Else
            MsgBox ("Нет данных для свода !")
            Exit Sub
    End If
    Set wrkResultSet = Nothing

'чистим критерий
With sheetsService
    .Range(.Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN), .Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN + KRIT_RAZDEL_COLUMNCOUNT - 1)) = ""
End With

'основной цикл
row = 1
For i = 1 To sheetsService.Range("B23")
    'добавим лист в новую книгу
    'Set sheet = newBook.Sheets.Add
    sheetsService.Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN) = i
    sheetsService.Cells(KRIT_RAZDEL_ROW + 3, KRIT_RAZDEL_COLUMN).CALCULATE
    'sheet.Name = sheetsService.Cells(KRIT_RAZDEL_ROW + 3, KRIT_RAZDEL_COLUMN)
    
    razdStr = VBA.Trim(VBA.str(i))
    Set sheetsReport = Sheets(VBA.Trim(sheetsService.Cells(KRIT_RAZDEL_ROW + 3, KRIT_RAZDEL_COLUMN)))
    
    repRowFirst = sheetsReport.Range("TITLE_" + razdStr).Rows.count + 1
    repRowLast = sheetsReport.Range("FOOTER_" + razdStr).row - 1
    
    div = sheetsReport.Range("DIVISION_" + razdStr).column
    dep = sheetsReport.Range("DEPARTMENT_" + razdStr).column
    tgt = sheetsReport.Range("TARGETITEM_" + razdStr).column
    exp = sheetsReport.Range("EXPEND_" + razdStr).column
    sum = sheetsReport.Range("MAIN_DATA_" + razdStr).column
    
    'sheetsReport.Range("TITLE_" + razdStr).Copy Destination:=newBook.Sheets(sheet.Name).Range("A1")
    lineCount = repRowLast - repRowFirst + 1
    ReDim codeArr(lineCount)
    ReDim linkArr(lineCount)
    
    codeCol = sheetsReport.Range("CODE_STR_" + razdStr).column
    For j = 1 To lineCount
        lnk = sheetsReport.Cells(j - 1 + repRowFirst, 1).value
        If lnk <> 0 Then
            linkArr(j) = j - 1 + sheetsService.Range("C5")
            codeArr(j) = VBA.Trim(sheetsReport.Cells(j - 1 + repRowFirst, codeCol))
        End If
    Next
    
    ' защита листа снимаем
    sheetsReport.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
    sheetsReport.Rows(VBA.Trim(VBA.str(repRowFirst + 1)) + ":" + VBA.Trim(VBA.str(repRowLast))).Delete
    sheetRow = repRowFirst
    oldRow = 0
    oldGraf = 0
    Do While IIf(Sheets("Service").Range("B23") > 1, sheetsSQLDATA2.Cells(row, 13) = i, sheetsSQLDATA2.Cells(row, 13) <> "")
        
        If (oldRow <> sheetsSQLDATA2.Cells(row, 10)) Or ((oldRow = sheetsSQLDATA2.Cells(row, 10)) And (oldGraf = sheetsSQLDATA2.Cells(row, 11))) Then
            sheetRow = sheetRow + 1
            sheetsReport.Rows(sheetRow).Insert
            oldRow = sheetsSQLDATA2.Cells(row, 10)
            oldGraf = sheetsSQLDATA2.Cells(row, 11)
        End If
        
        sheetsReport.Cells(sheetRow, div) = sheetsSQLDATA2.Cells(row, 3).Text
        sheetsReport.Cells(sheetRow, dep) = sheetsSQLDATA2.Cells(row, 4).Text
        sheetsReport.Cells(sheetRow, tgt) = sheetsSQLDATA2.Cells(row, 5).Text
        sheetsReport.Cells(sheetRow, exp) = sheetsSQLDATA2.Cells(row, 6).Text
        sheetsReport.Cells(sheetRow, sum + sheetsSQLDATA2.Cells(row, 11) - 1) = sheetsSQLDATA2.Cells(row, 12).Text
        
        sheetsReport.Cells(sheetRow, codeCol) = codeArr(sheetsSQLDATA2.Cells(row, 10))
        row = row + 1
    Loop
    sheetsReport.Rows(repRowFirst).Delete
'    row = row + 1
Next
'CALL HideLists()
    On Error Resume Next
    Sheets("SQLData").Visible = xlVeryHidden
    Sheets("Service").Visible = xlVeryHidden
    Sheets("Form").Visible = xlVeryHidden
    Sheets("Alg").Visible = xlVeryHidden
    Sheets("Otbor_Cond").Visible = xlVeryHidden
    Sheets("SEEK_POP_SQLDATA").Visible = xlVeryHidden
    Sheets("SQLData1").Visible = xlVeryHidden
    Sheets("Контроль").Visible = xlVeryHidden
    Sheets("Расшифровка").Visible = xlVeryHidden
    Sheets("SQLDATA2").Visible = False
    On Error GoTo 0
sheetsService.Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN) = ""
Exit Sub
doError:
    'Call ERROR_EVENT("Server_Connect")
End Sub

Sub doSvodNew()
Dim sheetsService As Object, sheetsReport As Object, sheet, sheetsSQLDATA2 As Object
Dim KRIT_RAZDEL_COLUMNCOUNT As Long, KRIT_RAZDEL_COLUMN As Long, KRIT_RAZDEL_ROW As Long
Dim newBook, bookName, nameRep, wrkCount, sqlStr, wrkResultSet, bookRep, i, j
Dim codeArr() As String, linkArr() As Integer, nameArr() As String, lineCount As Long, codeCol As Integer, razdStr As String
Dim lnk, repRowFirst As Integer, repRowLast As Integer, sheetRow As Integer
Dim sum, row, oldRow, lnDevide, oldGraf, summa() As Double, nameCol As Integer
Dim oldKey As String
'myError
Set sheetsService = Sheets("Service")
Set sheetsSQLDATA2 = Sheets("SQLDATA2")
pnODBC = VBA.Trim(sheetsService.Range("A3").value)  'DAtaSource
pnLogin = VBA.Trim(sheetsService.Range("A5").value) 'Login
pnParol = VBA.Trim(sheetsService.Range("A6").value) 'Parol
pndbNameSql = VBA.Trim(sheetsService.Range("A4").value) 'Name DB SQL

With Sheets("Service")
    KRIT_RAZDEL_COLUMNCOUNT = .Range("KRIT_RAZDEL").Columns.count
    KRIT_RAZDEL_COLUMN = .Range("KRIT_RAZDEL").column
    KRIT_RAZDEL_ROW = .Range("KRIT_RAZDEL").row
End With
lnDevide = sheetsService.Range("A29").value
'stop
'SQL-запрос
    Call Server_Connect
    sqlStr = sheetsService.Range("B37").Text
    
    ' выполнение
    Set wrkResultSet = pnwrkConnect.OpenRecordset("EXECUTE A_EXEC ' " + sqlStr + " '", dbOpenDynaset)
    ' получим LINK  объекта
    If wrkResultSet.EOF = False Then ' данные есть
            ' заполнение таблицы с данными
            wrkCount = 0
            While Not wrkResultSet.EOF
                If wrkCount <> 0 Then wrkResultSet.MoveNext

                Sheets("SQLDATA2").Cells(1 + wrkCount * 200, 1).CopyFromRecordset wrkResultSet, 200, wrkResultSet.Fields.count
                wrkCount = wrkCount + 1
            Wend
            'Sheets("SQLDATA2").Cells(wrkResultSet.RecordCount + 1, 1) = ""
    Else
            MsgBox ("Нет данных для свода !")
            Exit Sub
    End If
    Set wrkResultSet = Nothing

'чистим критерий
With sheetsService
    .Range(.Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN), .Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN + KRIT_RAZDEL_COLUMNCOUNT - 1)) = ""
End With

'основной цикл
'Stop
row = 1
For i = 1 To sheetsService.Range("B23")
    sheetsService.Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN) = i
    sheetsService.Cells(KRIT_RAZDEL_ROW + 3, KRIT_RAZDEL_COLUMN).CALCULATE
    
    razdStr = VBA.Trim(VBA.str(i))
    Set sheetsReport = Sheets(VBA.Trim(sheetsService.Cells(KRIT_RAZDEL_ROW + 3, KRIT_RAZDEL_COLUMN)))
    sheetsReport.Activate

    ' защита листа снимаем
    sheetsReport.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False

    ReDim summa(sheetsService.Range("A10") + 1)
    For j = 1 To sheetsService.Range("A10")
        summa(j) = 0
    Next
    repRowFirst = sheetsReport.Range("TITLE_" + razdStr).Rows.count + 1
    repRowLast = sheetsReport.Range("FOOTER_" + razdStr).row - 1
    
    sum = sheetsReport.Range("MAIN_DATA_" + razdStr).column
    
    lineCount = repRowLast - repRowFirst + 1
    
    ' защита листа снимаем
    sheetsReport.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
    'Stop
    If repRowFirst <> repRowLast Then sheetsReport.Rows(VBA.Trim(VBA.str(repRowFirst + 1)) + ":" + VBA.Trim(VBA.str(repRowLast))).Delete
    sheetRow = repRowFirst
    oldRow = 0
    oldGraf = 0
    oldKey = ""
    Do While IIf(Sheets("Service").Range("B23") > 1, sheetsSQLDATA2.Cells(row, 1) = i, sheetsSQLDATA2.Cells(row, 1) <> "")
        'sheetsSQLDATA2.Visible = True
        
        sheetRow = sheetRow + 1
        sheetsReport.Rows(sheetRow).Insert
        oldKey = sheetsSQLDATA2.Cells(row, 5)
        oldRow = sheetsSQLDATA2.Cells(row, 2)
        oldGraf = sheetsSQLDATA2.Cells(row, 3)
        
        'Вывод текстовых данных
        For j = 3 To sheetsService.Range("C6") - 1
            sheetsReport.Cells(sheetRow, j) = sheetsSQLDATA2.Cells(row, j + 3)
        Next
        sheetsReport.Cells(sheetRow, j).Rows.AutoFit
        
        'Вывод числовой информации
        While IIf(Sheets("Service").Range("B23") > 1, sheetsSQLDATA2.Cells(row, 1) = i, sheetsSQLDATA2.Cells(row, 1) <> "") And oldRow = sheetsSQLDATA2.Cells(row, 2) And oldKey = sheetsSQLDATA2.Cells(row, 5)
            sheetsReport.Cells(sheetRow, sheetsService.Range("C6") + sheetsSQLDATA2.Cells(row, 3) - 1) = VBA.Val(sheetsSQLDATA2.Cells(row, 4).Text)
            row = row + 1
        Wend
    Loop
    For j = 1 To sheetsService.Range("A10")
        sheetsReport.Cells(sheetRow + 1, sheetsService.Range("C6") + j - 1) = summa(j)
    Next
    sheetsReport.Rows(repRowFirst).Delete
'    row = row + 1
    ActiveWindow.DisplayHeadings = True
    Call SetPageHeight
    Call SetLastRowsCount(11)
    ' защита листа снимаем
    sheetsReport.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
Next
sheetsService.Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN) = ""
pnUser = 1
Exit Sub
doError:
    'Call ERROR_EVENT("Server_Connect")

End Sub

Public Sub AfterFullSvodF603()
Dim sheetsSEEK_POP_SQLDATA, row As Integer, sum999999 As Double
Dim constStr As String, lcCodeStr  As String, i As Integer, flag As Boolean, sqlStr As String
Dim ofk As String, sname As String, last As Integer, rowTarget As Integer
Dim wrkResultSet

    sqlStr = "select [SNAME]=sname, [OFK]=left(value,2) " + _
        "from s_corr_app a,s_corr c " + _
        "where  a.object=(      select link " + _
        "       from s_objects " + _
        "       where code=''COLUMN_DICT_OFK_CODE'') " + _
        "       and a.link_up=c.link and c.Link = " + VBA.Trim(VBA.str(Sheets("Service").Range("A16")))

    ' выполнение
    Set wrkResultSet = pnwrkConnect.OpenRecordset("A_EXEC ' " + sqlStr + " '", dbOpenDynaset)
    ' получим LINK  объекта
    If wrkResultSet.EOF = False Then ' корреспондент есть
        sname = wrkResultSet("SNAME")
        ofk = wrkResultSet("OFK")
    Else
        sname = ""
        ofk = ""
    End If
    
    row = Sheets("Расход").Range("TITLE_1").row + Sheets("Расход").Range("TITLE_1").Rows.count
    last = Sheets("Расход").Range("Footer_1").row - 1
    
    
    rowTarget = Sheets("Раздел 21").Range("ADD_603").row
    sum999999 = 0
    Sheets("Раздел 21").Protect DrawingObjects:=False, Contents:=False, Scenarios:=False

    For i = row To last
    '
        If VBA.Left(Sheets("Расход").Cells(i, 4).Text, 2) = "21" And Sheets("Расход").Cells(i, 11).value <> 0 And Sheets("Расход").Cells(i, 7) <> "800000" Then
            Sheets("Раздел 21").Cells(rowTarget, 3) = sname
            Sheets("Раздел 21").Cells(rowTarget, 4) = ofk
            Sheets("Раздел 21").Cells(rowTarget, 5) = Sheets("Расход").Cells(i, 3)
            Sheets("Раздел 21").Cells(rowTarget, 6) = Sheets("Расход").Cells(i, 4)
            Sheets("Раздел 21").Cells(rowTarget, 7) = Sheets("Расход").Cells(i, 5)
            Sheets("Раздел 21").Cells(rowTarget, 8) = Sheets("Расход").Cells(i, 6)
            Sheets("Раздел 21").Cells(rowTarget, 9) = Sheets("Расход").Cells(i, 7)
            Sheets("Раздел 21").Cells(rowTarget, 10) = Sheets("Расход").Cells(i, 11)
            Sheets("Раздел 21").Rows(rowTarget).AutoFit
            rowTarget = rowTarget + 1
            Sheets("Раздел 21").Rows(rowTarget).EntireRow.Insert
            sum999999 = sum999999 + Sheets("Расход").Cells(i, 11)
        End If
    Next
    Sheets("Раздел 21").Rows(rowTarget).EntireRow.Delete
    Sheets("Раздел 21").Rows(rowTarget).EntireRow.Delete
    Sheets("Раздел 21").Cells(rowTarget, 10) = sum999999
End Sub
