Attribute VB_Name = "INFILE_SMETA"
Option Explicit

Public fName As String

Public Type pageType
            razdelName As String
            grafCount As String
        End Type
Public razdelData() As pageType
Public codeArr() As String, linkArr() As Integer

Public Type codeType
            codeArr() As String
            linkArr() As Integer
        End Type
Public codeData() As codeType, itogStr As Integer, skiped_str As String, dataLinesCount As Integer, footerLinesCount As Integer, borderCount As Integer

Public Sub READ_FROM_FILE()

'myError
Dim StrLine As String, codeForm As String
Dim StrMonth As String, StrYear As String, lbExit As Boolean
Dim lnCodeError As Integer, lcFileName As String, sheetsService As Object, sheetsSEEK_POP_SQLDATA As Object
Dim col, row, corrName, CorrINN, LookRange As Range, Razdel, i, j
Dim div_flag As Boolean, dep_flag As Boolean, tgt_flag As Boolean, exp_flag As Boolean, code_flag As Boolean      'флаги выгрузки кодов
Dim iFlag As Integer
Dim tempStr As String, str As String
Dim sepCount As Integer

Set sheetsService = Sheets("Service")
Set sheetsSEEK_POP_SQLDATA = Sheets("SQLDATA2")
'прочитаем данные по разделам
ReDim razdelData(sheetsService.Range("B23"))
ReDim codeData(sheetsService.Range("B23"))
'чистим критерий
With sheetsService
    .Range(.Cells(KRIT_GRAF_ROW + 1, KRIT_GRAF_COLUMN), .Cells(KRIT_GRAF_ROW + 1, KRIT_GRAF_COLUMN + KRIT_GRAF_COLUMNCOUNT - 1)) = ""
    .Range(.Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN), .Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN + KRIT_RAZDEL_COLUMNCOUNT - 1)) = ""
End With

Sheets("Service").Range("A37").Value = 0
'Stop

'читаем структуру отчета
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
    razdelData(i).razdelName = sheetsService.Cells(KRIT_RAZDEL_ROW + 3, KRIT_RAZDEL_COLUMN).Text
    sheetsService.Cells(KRIT_GRAF_ROW + 1, KRIT_GRAF_COLUMN + 2) = i
    sheetsService.Cells(KRIT_GRAF_ROW + 6, KRIT_GRAF_COLUMN).CALCULATE
    razdelData(i).grafCount = sheetsService.Cells(KRIT_GRAF_ROW + 6, KRIT_GRAF_COLUMN) - 1
Next

'Stop

'имя файла
lcFileName = sheetsService.Range("A31")
'добавим в конец / (если нет)
i = VBA.Len(lcFileName)
While (VBA.Mid(lcFileName, i, 1) <> "\") And i > 1
    i = i - 1
Wend
fName = VBA.Mid(lcFileName, i + 1, (VBA.Len(lcFileName) - i) - (VBA.Len(lcFileName) - VBA.InStr(i, lcFileName, ".")) - 1)

'запишем общие данные в файл отчета
Open sheetsService.Range("B47") + fName + "." + sheetsService.Range("A50") For Output As #2
Print #2, "Протокол приема " + sheetsService.Range("B47") + fName + "." + sheetsService.Range("A50")
Print #2, "Форма № " + VBA.Trim(sheetsService.Range("B15")) + "   Дата " + VBA.str(Date) + "  Время " + VBA.str(Time)
Print #2, "Принимаемый файл  " + lcFileName

'pPermitUpd = True ' для заполнения коллекции для сохранения
Sheets("Service").Range("A37").Value = 0
On Error GoTo ERROR_HANDLE
lnCodeError = 2
Open lcFileName For Input As #1
lineNum = 0
lnCodeError = 0
lnCodeError = readHead
If lnCodeError <> 0 Then GoTo ERROR_HANDLE

'Stop
'Razdel = VBA.Val(sheetsService.Range("B20"))
' создадим список кодов для загрузки
'dep_flag = exists_name("DEPARTMENT_" + VBA.Trim(VBA.str(Razdel)))
'div_flag = exists_name("DIVISION_" + VBA.Trim(VBA.str(Razdel)))
'tgt_flag = exists_name("TARGETITEM_" + VBA.Trim(VBA.str(Razdel)))
'exp_flag = exists_name("EXPEND_" + VBA.Trim(VBA.str(Razdel)))
'If dep_flag Then
'    code_flag = IIf(Application.Names("DEPARTMENT_" + VBA.Trim(VBA.str(Razdel))).RefersToRange.Column = Application.Names("CODE_STR_" + VBA.Trim(VBA.str(Razdel))).RefersToRange.Column, False, True)
'Else
'    code_flag = True
'End If


'читаем общие данные
For i = 1 To dataLinesCount
    StrLine = ReadLine(iFlag)
    If chr_count(StrLine, vbTab) <> borderCount Then
        skiped_str = skiped_str + StrLine + "  /* НЕВЕРНОЕ ЧИСЛО РАЗДЕЛИТЕЛЕЙ */" + VBA.Chr(13)
    Else
        tempStr = getNextSubstr(StrLine, vbTab)
        Set LookRange = Sheets(sheetsService.Range("B19").Text).Range("CODE_STR").Find(tempStr, LookIn:=xlFormulas, lookat:=xlWhole)
        If Not LookRange Is Nothing Then
            ' пропишем ячейку в отчет (посмотреть настройку на Ед.Изм)
            row = LookRange.row
        Else
            row = 0
        End If
        If row <> 0 Then
            For j = 1 To borderCount
                tempStr = getNextSubstr(StrLine, vbTab)
                If (VBA.Val(tempStr) = 0 And tempStr <> "0.00" And tempStr <> "0") And tempStr <> "" Then  ' не число, или затесались не цифры
                    skiped_str = skiped_str + StrLine + "  /* ОБНАРУЖЕНО НЕЧИСЛОВОЕ ЗНАЧЕНИЕ - " + tempStr + " - записано как 0.00 */" + Chr(13)
                    tempStr = "0.00"
                End If
                Sheets(sheetsService.Range("B19").Text).Cells(row, sheetsService.Range("C6") - 1 + j) = tempStr
            Next
        Else
           skiped_str = skiped_str + tempStr + vbTab + StrLine + "  /* НЕИЗВЕСТНЫЙ КОД СТРОКИ */" + VBA.Chr(13)
        End If
    End If
Next

lExit:

'sheetsSEEK_POP_SQLDATA.Cells(row, 1).Value = ""
'Call CLEAR_CONTROL

If skiped_str = "" Then
    Print #2, "- в структуре и заголовке файла ошибок не обнаружено"
Else
    Print #2, "- в структуре и заголовке файла обнаружены ошибки:"
    Print #2, skiped_str
End If
skiped_str = ""
Print #2, "------------------------------------------------------------"

'Stop
Close #1
Close #2

' Вызов процедуры записи в журнал успешной записи
'Call WRITE_ERROR_MAG(lnCodeError)
' Установка флага конца операции
sheetsService.Range("A59") = 1

If sheetsService.Range("A15") = "DOCUMENTS_SVOD_F614" Or sheetsService.Range("A15") = "DOCUMENTS_SVOD_F714" Or sheetsService.Range("A15") = "DOCUMENTS_F614" Or sheetsService.Range("A15") = "DOCUMENTS_F714" Then Call ADD_ITOG_STR
Exit Sub
ERROR_HANDLE:
If ERR.number = 62 Then ' ошибка чтения файла (конец файла)
    lnCodeError = 1
    On Error GoTo 0
End If
'Sheets("Контроль").Range("CLEAR_CONTROL").CLEAR
row = Sheets("Контроль").Range("CLEAR_CONTROL").row
col = Sheets("Контроль").Range("CLEAR_CONTROL").Column
Call CLEAR_CONTROL
Select Case lnCodeError
    Case 1
        Sheets("Контроль").Cells(row, col) = "Неожиданный конец файла, строка " + VBA.str(lineNum)
    Case 2
        Sheets("Контроль").Cells(row, col) = "Ошибка в заголовке файла, строка " + VBA.str(lineNum)
    Case 7
        Sheets("Контроль").Cells(row, col) = "Неизвесный корреспондент, строка " + VBA.str(lineNum)
    Case 8
        Sheets("Контроль").Cells(row, col) = "Неверная дата отчета, строка " + VBA.str(lineNum)
    Case 9
        Sheets("Контроль").Cells(row, col) = "Нельзя определить код строки, строка " + VBA.str(lineNum)
    Case 10
        Sheets("Контроль").Cells(row, col) = "Нет разделителя, строка " + VBA.str(lineNum)
    Case 11
        Sheets("Контроль").Cells(row, col) = "Неверный тип данных, строка " + VBA.str(lineNum)
    Case 99
        Sheets("Контроль").Cells(row, col) = ""
    Case Else
        Sheets("Контроль").Cells(row, col) = "Неизвесная ошибка, строка " + VBA.str(lineNum)
End Select
Print #2, "Ошибка в структуре файла: " + Sheets("Контроль").Cells(row, col)

Sheets("Контроль").Cells(row + 1, col) = "Файл не принят"
Sheets("Контроль").Cells(row + 1, col).Interior.ColorIndex = 3
Close #1
Close #2

' Вызов процедуры записи в журнал об ошибке
'Call WRITE_ERROR_MAG(lnCodeError)
' Установка флага конца операции
sheetsService.Range("A59") = 0
End Sub

' Процедура сохранения отчета на SQL Server при приеме файла
Sub SAVE_REPORT_FROM_FILE() 'fileName As String,flag As Boolean
'myerror
Dim SqlStr As String, nCnt As Integer, nCountColl As Integer, nCol As Integer, nCount As Integer
Dim metric As Integer, lnDevide As Long
Dim wrkResultSet As DAO.Recordset, lnLinkObject As Integer, lnObject As Integer
Dim sheetsService As Object, sheetsReport As Object
Dim DeletedLink As String, lnLink As Long, LookRange As Range, CurrRow As Long
Dim lbExistsValue As Boolean, SqlStr1 As String, SqlStrDel As String
Dim row, col, hWnd, i As Integer ', Razdel As Integer
Dim link As String
'Dim div_flag As Boolean, dep_flag As Boolean, tgt_flag As Boolean, exp_flag As Boolean, code_flag As Boolean      'флаги выгрузки кодов

    'if fileName<>"" then
    '   Application.ScreenUpdating = True
    '   Application.StatusBar = "Подождите ... Идет сохранение данных файла "+ fileName
    '   Application.ScreenUpdating = False
    'endif
    
    Set sheetsService = Application.ActiveWorkbook.Sheets("Service")
    Set sheetsReport = Application.ActiveWorkbook.Sheets(Sheets("Service").Range("B19").Text)
    ' Сохранение документа в зависимости от режима ввода
    ' 2 - вставка новых записей
    ' Определим единицу измерения и переведем в копейки
    lnDevide = sheetsService.Range("A29").Value
    
    'раздел
    i = sheetsService.Range("B20")
    
    ' Определим есть ли соединение с сервером
    If pnwrkConnect Is Nothing Then
        Call Server_Connect
    End If
    
    ' получим LINK  объекта
    SqlStr = "SELECT LINK FROM S_OBJECTS WHERE CODE='" + VBA.Trim(sheetsService.Range("A15")) + "'"
    ' тvяюыэхэш
    Set wrkResultSet = pnwrkConnect.OpenRecordset(SqlStr, dbOpenDynaset)
    ' яюыєўшь LINK  юс·хъЄр
    link = VBA.Trim(VBA.str(wrkResultSet("LINK")))
    
'    Stop
    SqlStr = "EXECUTE V_ADD_REPORT_FIELDS_INPUT " + VBA.str(link) + _
            ", " + VBA.Trim(VBA.str(sheetsService.Range("A16"))) + _
            ", '" + VBA.Trim(sheetsService.Range("A18")) + _
            "', '" + VBA.Trim(sheetsService.Range("A19")) + _
            "', '" + VBA.Trim(sheetsService.Range("B28")) + _
            "', '" + VBA.Trim(sheetsService.Range("B27")) + _
            "', '" + VBA.Trim(sheetsService.Range("B29")) + _
            "', '" + VBA.Trim(sheetsService.Range("B30")) + "'"
    Set wrkResultSet = Nothing
    Set wrkResultSet = pnwrkConnect.OpenRecordset(SqlStr, dbOpenDynaset)
    
    Do
        If wrkResultSet("LINK").Type = dbText Then
            If VBA.Trim(wrkResultSet("LINK")) = "RETURN_LINK" Then
                lnObject = wrkResultSet("LINK_UP")
                lbExistsValue = IIf(VBA.Val(wrkResultSet("EXISTS")) = 1, True, False)
            End If
            If VBA.Trim(wrkResultSet("LINK")) = "KBK" Then
                If (IIf(IsNull(wrkResultSet("DEP")), "", wrkResultSet("DEP")) <> sheetsService.Range("B28")) Then
                    Print #2, "Неизвестное ведомство """ + VBA.Trim(sheetsService.Range("B28")) + """"
                End If
                If (IIf(IsNull(wrkResultSet("DIV")), "", wrkResultSet("DIV")) <> sheetsService.Range("B27")) Then
                    Print #2, "Неизвестный подраздел """ + VBA.Trim(sheetsService.Range("B27")) + """"
                End If
                If (IIf(IsNull(wrkResultSet("TGT")), "", wrkResultSet("TGT")) <> sheetsService.Range("B29")) Then
                    Print #2, "Неизвестная целевая статья """ + VBA.Trim(sheetsService.Range("B29")) + """"
                End If
                If (IIf(IsNull(wrkResultSet("EXP")), "", wrkResultSet("EXP")) <> sheetsService.Range("B30")) Then
                    Print #2, "Неизвестный вид расхода """ + VBA.Trim(sheetsService.Range("B30")) + """"
                End If
            End If
        End If
    Loop While wrkResultSet.NextRecordset

    If lbExistsValue Then ' отчет есть
        ' Смотрим настройку перезаписи отчета
         If sheetsService.Range("A60") <> 1 Then
    
            Set LookRange = Sheets("Контроль").Range("A5:A60000").Find("", LookIn:=xlFormulas, lookat:=xlWhole, SearchOrder:=xlByRows)
            row = LookRange.row
            Set LookRange = Nothing
    
            'row = Sheets("Контроль").Range("CLEAR_CONTROL").row
            col = Sheets("Контроль").Range("CLEAR_CONTROL").Column
            Sheets("Контроль").Cells(row + 1, col) = "Данные уже имеются в базе данных"
            Sheets("Контроль").Cells(row + 2, col) = "Данные файла не сохранены"
            Sheets("Контроль").Cells(row + 2, col).Interior.ColorIndex = 3
            
            sheetsService.Range("A59") = 1
            Print #2, "Данные уже имеются в базе данных -> не сохраняем"
            Exit Sub
         End If
    End If
    
    Set wrkResultSet = Nothing
    'удалить данные по разделу
    SqlStr = " DELETE FROM REPORT_VALUES WHERE LINK_UP =" + VBA.str(lnObject) + " AND OBJECT = " + VBA.str(i)

    pnwrkConnect.Execute (SqlStr)

'    Stop 'здесь надо добавить запись в report_add_fields
    
    With ThisWorkbook.Sheets("Service")
        pnAddress_Row = .Range("C5")
        pnAddress_Col = .Range("C6")
    End With
    'Sheets(sheetsService.Range("B19").Text).Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
    Set sheetsReport = Sheets(sheetsService.Range("B19").Text)
    
' Этап 2 вставка новых записей
    SqlStr = ""
    nCountColl = pINSColl(i).count
    If nCountColl > 0 Then 'есть записи для вставки
        For nCnt = 1 To nCountColl
            SqlStr1 = ""
            lnLink = pINSColl(i)(nCnt)
            Set LookRange = sheetsReport.Range("LINK").Find(lnLink, LookIn:=xlFormulas, lookat:=xlWhole)
            If Not LookRange Is Nothing Then
                CurrRow = LookRange.row
                lbExistsValue = False
                'If str_status(nCnt) = 0 Then
                    For nCol = 0 To sheetsService.Range("A10") - 1
                                SqlStr1 = SqlStr1 + " INSERT REPORT_VALUES (LINK_UP,OBJECT,BARS,GRAFS,VALUE) VALUES(" + _
                                VBA.Trim(VBA.str(lnObject)) + "," + IIf(sheetsService.Range("B23") = 1, "0", VBA.str(i)) + "," + _
                                VBA.Trim(VBA.str(lnLink)) + "," + _
                                VBA.Trim(VBA.str(nCol + 1)) + "," + _
                                VBA.Trim(VBA.str(sheetsReport.Cells(CurrRow, pnAddress_Col + nCol).Value * lnDevide)) + ")"
                                ' Проверка на наличия значений
                                If sheetsReport.Cells(CurrRow, pnAddress_Col + nCol).Value <> 0 Then
                                    lbExistsValue = True
                                End If
                    Next
                'End If
                'если все значения = 0 то не записываем
                If lbExistsValue Then
                    SqlStr = SqlStr + SqlStr1
                    lbExistsValue = False
                    ' Заносим в коллекцию уже существующих
                    'pNotEmptyColl(i).Add lnLink, VBA.Trim(VBA.str(lnLink))
                End If
                'Сформируем строку insert на SQL Server
                ' Проверим пакет
                If VBA.Len(SqlStr) > 300000 Then
                    ' Выполняем пакет команд
                    pnwrkConnect.Execute (SqlStr)
                    SqlStr = ""
                End If
            End If
        Next
       ' Удаление из коллекции
        For nCnt = 1 To pINSColl(i).count
            pINSColl(i).Remove (1)
        Next
        'Выполним оставшиеся insert на SQL Server
        If SqlStr <> "" Then
            pnwrkConnect.Execute (SqlStr)
        End If
    End If
'Next
' Установка флага конца операции
sheetsService.Range("A59") = 0
End Sub

Sub SVOD_TO_FILE()
'myError
Dim sheetsService As Object
Dim lcFileName As String, lcPath As String, lcShablon As String, _
    lcKodReg As String, lcNumCor  As String, lnRes As Long, lcDay
Dim SqlStr, wrkResultSet, lnDevide, wrkCount, row As Integer, temp, i, rowTemp, Razdel, LookRange As Range

        Set sheetsService = Sheets("Service")
        lcPath = sheetsService.Range("A54")
        lnDevide = sheetsService.Range("A29").Value

MetFile:

    
    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
    For i = 1 To sheetsService.Range("B23") 'для всех листов формируем файлы
        sheetsService.Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN + 1) = ""
        sheetsService.Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN) = i
        sheetsService.Cells(KRIT_RAZDEL_ROW + 3, KRIT_RAZDEL_COLUMN).CALCULATE
    
        If sheetsService.Range("B23") <> 1 Then
            Application.ActiveWorkbook.Sheets(sheetsService.Cells(KRIT_RAZDEL_ROW + 3, KRIT_RAZDEL_COLUMN).Text).Activate
        Else
            Application.ActiveWorkbook.Sheets(sheetsService.Range("B19").Text).Activate
        End If
        
        lcFileName = sheetsService.Range("B49")
        Open Replace_in_Str(sheetsService.Range("B50"), "%N", VBA.Trim(VBA.str(i))) For Output As #2
        lcFileName = Replace_in_Str(lcFileName, "%N", VBA.Trim(VBA.str(i)))
        
        'чистим столбец
        Set LookRange = Sheets("SQLDATA2").Columns(1).Find("", LookIn:=xlFormulas, lookat:=xlWhole, SearchOrder:=xlByRows)
        If Not LookRange Is Nothing Then
            With Sheets("SQLDATA2")
                .Range(.Cells(1, 1), .Cells(LookRange.row, 1)) = ""
            End With
        End If
        Call Server_Connect
        SqlStr = "EXECUTE V_GET_OUTPUT_DATA '" + sheetsService.Range("A15") + "', " + VBA.Trim(Sheets("Service").Range("A16").Text) + ",'" + VBA.Trim(Sheets("Service").Range("A18").Text) + "','" + VBA.Trim(Sheets("Service").Range("A19").Text) + "','','','',' T.OBJECT = " + IIf(sheetsService.Range("B23") = 1, "0", str(i)) + "'"

        ' выполнение
        Set wrkResultSet = pnwrkConnect.OpenRecordset(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) = ""
                Sheets("Service").Range("C10") = Replace_in_Str(VBA.Trim(Sheets("Service").Range("C10").Text), "F", "")
        Else
                MsgBox ("Нет данных для пердачи (раздел " + VBA.Trim(VBA.str(i)) + ")")
                GoTo nnn
        End If
        Set wrkResultSet = Nothing
        
        Open lcFileName For Output As #1
        
        Call WRITE_TO_FILE(lcFileName)
                
        Print #2, "Контроль файла для передачи в вышестоящий орган."
            
        If (sheetsService.Range("B50").Text <> "") And (sheetsService.Range("A62").Text = "1") Then
            Sheets("Service").Range("A30") = 1
            Call control
        Else
            Print #2, "  Файл не контролировался "
        End If
        Close 2
nnn:
    Next
'Контроль
errror:
'End If
End Sub


Sub WRITE_TO_FILE(ByVal lcFileName As String)
'myError
Dim sheetsService As Object, sheetsReport As Object, sheetsSEEK_POP_SQLDATA As Object
Dim lcMonth As String, lcYear As String, lcCodeReg As String, lcCodeDoc As String, lcDate As String, _
    lnOutEmptyBars  As Integer, lcLineValue As String, lcCodeStr As String, _
    nCnt As Long, nCntCol As Long, lcValue As String, lnSumma As Double, Razdel As String, row As Long, _
    codeArr() As String, linkArr() As Integer, i As Integer, link As Long, lineCount As Long, codeCol As Integer, _
    bar As String, summa() As Double, addFlag As Boolean, number As String, num As Integer, lnColumn1, lnRow1, colCounter, j
Dim div_flag As Boolean, dep_flag As Boolean, tgt_flag As Boolean, exp_flag As Boolean, code_flag As Boolean      'флаги выгрузки кодов
Dim constStr As String 'постоянная часть строки (99999 999 999 и т.п.)
Dim flag800000 As Boolean 'true - выводить коды 800000
Dim borderCount As Integer
Dim codeColumn As Integer
Dim flag605 As Boolean, subItog605(2, 8) As Double
Dim itogMask As String

On Error GoTo doError

Application.StatusBar = "Подождите ... Идет запись в файл"

Set sheetsService = Sheets("Service")
Set sheetsReport = Sheets(Sheets("Service").Range("B19").Text)
Set sheetsSEEK_POP_SQLDATA = Sheets("SQLDATA2")

'Stop
Call writeHead_svod
row = 1
Razdel = ""

' Формирование информативной части
With sheetsService
     lnColumn1 = KRIT_RAZDEL_COLUMN
     lnRow1 = KRIT_RAZDEL_ROW
     .Range(.Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN), .Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN + KRIT_RAZDEL_COLUMNCOUNT - 1)) = ""
End With

lcCodeStr = ""
bar = ""
addFlag = False

Do While sheetsSEEK_POP_SQLDATA.Cells(row, 1).Text <> ""

    If Razdel <> VBA.Trim(sheetsSEEK_POP_SQLDATA.Cells(row, 1)) Then
    'сменить раздел
        If Razdel <> "" Then
            lcCodeStr = constStr
            For i = 1 To sheetsService.Range("A10")
                lcCodeStr = lcCodeStr + "  " + num_To_Str(summa(i), 16) + " "
                If flag605 Then subItog605(Razdel, i) = summa(i)
            Next
            Print #1, lcCodeStr
            i = 1
        End If
        
        colCounter = 0
        lcCodeStr = ""
        
        'смена раздела
        Razdel = VBA.Trim(sheetsSEEK_POP_SQLDATA.Cells(row, 1))
        
        sheetsService.Cells(lnRow1 + 1, lnColumn1) = Razdel
        If sheetsService.Range("B23") = 1 Then
            Set sheetsReport = Application.ActiveWorkbook.Sheets(sheetsService.Range("B19").Text)
'            Razdel = "0"
        Else
            Set sheetsReport = Application.ActiveWorkbook.Sheets(sheetsService.Cells(lnRow1 + 3, lnColumn1).Text)
        End If
        flag800000 = False 'IIf((sheetsService.Cells(lnRow1 + 7, lnColumn1) = 1) Or (sheetsService.Cells(lnRow1 + 7, lnColumn1) = ""), True, False)
        If sheetsService.Cells(lnRow1 + 6, lnColumn1).Text = "" Then codeColumn = 2 Else codeColumn = sheetsService.Cells(lnRow1 + 6, lnColumn1).Text
        itogMask = sheetsService.Cells(lnRow1 + 8, lnColumn1).Text
        If itogMask = "" Then itogMask = "999999"
        sheetsReport.Activate
        
        bar = sheetsSEEK_POP_SQLDATA.Cells(row, codeColumn)
        
        ReDim summa(sheetsService.Range("A10"))
        
        'смена раздела
        For i = 1 To sheetsService.Range("A10") 'IIf(VBA.Val(Razdel) = 1, 6, 1)
            summa(i) = 0
        Next
        
        ' создадим список кодов для выгрузки
        dep_flag = exists_name("DEPARTMENT_" + IIf(Razdel <> "0", Razdel, "1"))
        div_flag = exists_name("DIVISION_" + IIf(Razdel <> "0", Razdel, "1"))
        tgt_flag = exists_name("TARGETITEM_" + IIf(Razdel <> "0", Razdel, "1"))
        exp_flag = exists_name("EXPEND_" + IIf(Razdel <> "0", Razdel, "1"))
        If dep_flag Then
            code_flag = IIf(sheetsReport.Range("DEPARTMENT_" + IIf(Razdel <> "0", Razdel, "1")).Column = sheetsReport.Range("CODE_STR_" + IIf(Razdel <> "0", Razdel, "1")).Column, False, True)
'            If Not code_flag Then codeColumn = 3
        Else
            code_flag = True
        End If
        
        'итоговая строка
        constStr = IIf(dep_flag, "999 | ", "") + IIf(div_flag, "9999 | ", "") + IIf(tgt_flag, "999 | ", "") + IIf(exp_flag, "999 | ", "") + IIf(code_flag, "999999 | ", "")
        constStr = VBA.Left(constStr, VBA.Len(constStr) - 2)   ' убрали последний разделитель
        
        lineCount = sheetsService.Range("A9") - sheetsService.Range("C5") + 1
        ReDim codeArr(lineCount)
        ReDim linkArr(lineCount)

        codeCol = sheetsReport.Range("CODE_STR").Column
        For i = 1 To lineCount
            link = sheetsReport.Cells(i - 1 + sheetsService.Range("C5"), 1).Value
            If link <> 0 Then
                linkArr(i) = link
                codeArr(i) = VBA.Trim(sheetsReport.Cells(i - 1 + sheetsService.Range("C5"), codeCol))
            End If
        Next
        i = 1
'        Call writeRazdel(IIf(Razdel <> "0", VBA.Val(Razdel), 1))
        colCounter = 0
    End If
        
'        If dep_flag Then lcCodeStr = sheetsSEEK_POP_SQLDATA.Cells(row, 3).Text + Space(3 - Len(sheetsSEEK_POP_SQLDATA.Cells(row, 3).Text))
'        If div_flag Then lcCodeStr = IIf(lcCodeStr <> "", lcCodeStr + " | ", "") + sheetsSEEK_POP_SQLDATA.Cells(row, 4).Text + Space(4 - Len(sheetsSEEK_POP_SQLDATA.Cells(row, 4).Text))
'        If tgt_flag Then lcCodeStr = IIf(lcCodeStr <> "", lcCodeStr + " | ", "") + sheetsSEEK_POP_SQLDATA.Cells(row, 5).Text + Space(3 - Len(sheetsSEEK_POP_SQLDATA.Cells(row, 5).Text))
'        If exp_flag Then lcCodeStr = IIf(lcCodeStr <> "", lcCodeStr + " | ", "") + sheetsSEEK_POP_SQLDATA.Cells(row, 6).Text + Space(3 - Len(sheetsSEEK_POP_SQLDATA.Cells(row, 6).Text))
        If i > lineCount Then i = 1
        If code_flag And (linkArr(i) <> VBA.Val(bar)) Then
            For i = 1 To lineCount
                If linkArr(i) = VBA.Val(bar) Then
                    lcCodeStr = lcCodeStr + IIf(lcCodeStr <> "", vbTab, "") + codeArr(i)
                    GoTo eee
                End If
            Next
        Else
            If linkArr(i) = VBA.Val(bar) Then lcCodeStr = lcCodeStr + IIf(lcCodeStr <> "", vbTab, "") + codeArr(i)
        End If
eee:
    sheetsSEEK_POP_SQLDATA.Cells(row, 7) = codeArr(i)
    For j = 1 To sheetsService.Range("A10")
        If sheetsSEEK_POP_SQLDATA.Cells(row, 7 + j) = "" Then
            lcCodeStr = lcCodeStr + vbTab + num_To_Str(0, 15)
        Else
            lcCodeStr = lcCodeStr + vbTab + num_To_Str(VBA.Val(sheetsSEEK_POP_SQLDATA.Cells(row, 7 + j).Value), 15)
        End If
    Next
    If (codeArr(i) = "800000") Or (Not code_flag) Then
        For j = 1 To sheetsService.Range("A10")
            summa(j) = summa(j) + VBA.Val(sheetsSEEK_POP_SQLDATA.Cells(row, 7 + j).Value)
            If Not flag800000 And code_flag Then lcCodeStr = ""
        Next
    End If
sss:
    Print #1, lcCodeStr
    lcCodeStr = ""
    num = num + 1
    row = row + 1
    bar = sheetsSEEK_POP_SQLDATA.Cells(row, codeColumn)
Loop

If lcCodeStr <> "" Then
        Print #1, lcCodeStr
End If

'lcCodeStr = constStr
'For i = 1 To sheetsService.Range("A10")
'    lcCodeStr = lcCodeStr + "|" + num_To_Str(VBA.Val(VBA.str(summa(i))), 16) + " "
'    If flag605 Then subItog605(Razdel, i) = summa(i)
'Next
'Print #1, lcCodeStr

' Формирование заключительной части
Call writeFooter_svod
'Print #1, ""
'Print #1, "#"
'Print #1, convert_dos_win(sheetsService.Range("A50"), 1)
'Print #1, convert_dos_win(sheetsService.Range("A51"), 1)
Close #1
Application.StatusBar = False
Exit Sub
doError:
    Call ERROR_EVENT("WRITE_TO_FILE")
End Sub

Sub control_999()

Dim LookRange As Range, rowControl, colControl, errorFlag As Boolean
Dim corr As String, rowData, sheetsSQLDATA2 As Object, SqlStr, sum(6) As Double
Dim wrkResultSet As DAO.Recordset, flag, i, hWnd, err1 As String, err2 As String, err3 As String
    
'hWnd = FindWindow("XLMAIN", 0)
'LockWindowUpdate (hWnd)

    errorFlag = False
    Set sheetsSQLDATA2 = Sheets("SQLDATA2")
    Set LookRange = Sheets("Контроль").Range("A2:A60000").Find("", LookIn:=xlFormulas, lookat:=xlWhole, SearchOrder:=xlByRows)
    rowControl = LookRange.row
    Set LookRange = Nothing
    colControl = Sheets("Контроль").Range("CLEAR_CONTROL").Column
    Sheets("Контроль").Cells(rowControl, colControl) = "Проверка контрольных сумм"
    Sheets("Контроль").Cells(rowControl, colControl).Interior.ColorIndex = 6
    rowControl = rowControl + 1
    
    Print #2, "3. Анализ соответствия итоговых сумм"
    
    rowData = 1
    corr = ""
    For i = 1 To 6
        sum(i) = 0
    Next
    
'    Stop
    
    While VBA.Trim(sheetsSQLDATA2.Cells(rowData, 1)) <> ""
            If VBA.Trim(sheetsSQLDATA2.Cells(rowData, 7)) = "999999" Then
                flag = False
                For i = 1 To razdelData(sheetsSQLDATA2.Cells(rowData, 1)).grafCount
                    If sum(i) <> VBA.Val(sheetsSQLDATA2.Cells(rowData, 7 + i)) Then
                        Sheets("Контроль").Cells(rowControl + 1, colControl + 1 + i) = VBA.Val(sheetsSQLDATA2.Cells(rowData, 7 + i))
                        Sheets("Контроль").Cells(rowControl + 2, colControl + 1 + i) = sum(i)
                        Sheets("Контроль").Cells(rowControl + 3, colControl + 1 + i) = sum(i) - VBA.Val(sheetsSQLDATA2.Cells(rowData, 7 + i))
                        
                        err1 = err1 + "   " + Space(15 - VBA.Len(VBA.Format(VBA.Val(sheetsSQLDATA2.Cells(rowData, 7 + i)), "###0.00"))) + VBA.Format(VBA.Val(sheetsSQLDATA2.Cells(rowData, 7 + i)), "###0.00")
                        err2 = err2 + "   " + Space(15 - VBA.Len(VBA.Format(sum(i), "###0.00"))) + VBA.Format(sum(i), "###0.00")
                        err3 = err3 + "   " + Space(15 - VBA.Len(VBA.Format(sum(i) - VBA.Val(sheetsSQLDATA2.Cells(rowData, 7 + i)), "###0.00"))) + VBA.Format(sum(i) - VBA.Val(sheetsSQLDATA2.Cells(rowData, 7 + i)), "###0.00")
                        
                        flag = True
                    End If
                    
                    sum(i) = 0
                Next
                If flag Then
                    Sheets("Контроль").Cells(rowControl, colControl) = "Строка " + VBA.Trim(sheetsSQLDATA2.Cells(rowData, 1))
                    Sheets("Контроль").Cells(rowControl + 1, colControl) = "Введено     "
                    Sheets("Контроль").Cells(rowControl + 2, colControl) = "Расчитано   "
                    Sheets("Контроль").Cells(rowControl + 3, colControl) = "Расхождение "
                    
                    Print #2, " - раздел """ + VBA.Trim(razdelData(sheetsSQLDATA2.Cells(rowData, 1)).razdelName) + """"
                    
                    Print #2, "  " + Sheets("Контроль").Cells(rowControl + 1, colControl) + err1
                    Print #2, "  " + Sheets("Контроль").Cells(rowControl + 2, colControl) + err2
                    Print #2, "  " + Sheets("Контроль").Cells(rowControl + 3, colControl) + err3
                    
                    rowControl = rowControl + 4
                    errorFlag = True
                End If
            Else
                For i = 1 To razdelData(sheetsSQLDATA2.Cells(rowData, 1)).grafCount
                    If VBA.Trim(sheetsSQLDATA2.Cells(rowData, 7)) = "800000" Then
                        sum(i) = sum(i) + VBA.Val(sheetsSQLDATA2.Cells(rowData, 7 + i))
                    End If
                Next
            End If
            
'        End If
        rowData = rowData + 1
    Wend
    
    ' Установка флага конца операции
    If errorFlag Then
        Sheets("Service").Range("A59") = 1
        Print #2, " - обнаружены несоответствия контрольных сумм "
    Else
        Sheets("Service").Range("A59") = 0
        Print #2, " - несоответствия контрольных сумм не обнаружены "
    End If
    
    Print #2, "------------------------------------------------------------"

'LockWindowUpdate (0)
End Sub

Sub control()
'myError
Dim sheetsService As Object, sheetsReport As Object
Dim DeletedLink As String, lnLink As Long, LookRange As Range, CurrRow As Long
Dim lbExistsValue As Boolean, SqlStr1 As String, SqlStrDel As String
Dim row, col, Razdel As String, sheetsSQLDATA2 As Object
Dim codeArr() As String, linkArr() As Integer, i As Integer, lineCount As Long, codeCol As Integer, _
    bar As Integer, summa(3) As Double, addFlag As Boolean, div, dep, tgt, exp, sqlStr_raf, lnk, linkCorr, sss, _
    errorFlag As Boolean, colControl, hWnd, j

'hWnd = FindWindow("XLMAIN", 0)
'LockWindowUpdate (hWnd)

    Print #2, "4. Контроль по контрольным соотношениям"
'    Stop
    Set sheetsService = Application.ActiveWorkbook.Sheets("Service")
    'Set sheetsReport = Application.ActiveWorkbook.Sheets(Sheets("Service").Range("B19").Text)
    Set sheetsSQLDATA2 = Sheets("SQLDATA2")
    colControl = Sheets("Контроль").Range("CLEAR_CONTROL").Column
    
    lineCount = sheetsService.Range("A9") - sheetsService.Range("C5") + 1
    ReDim codeArr(lineCount)
    ReDim linkArr(lineCount)
    
    errorFlag = False
    
    div = sheetsSQLDATA2.Cells(1, 3)
    dep = sheetsSQLDATA2.Cells(1, 4)
    tgt = sheetsSQLDATA2.Cells(1, 5)
    exp = sheetsSQLDATA2.Cells(1, 6)
    OldBK = div + ", " + dep + ", " + tgt + ", " + exp

    Razdel = sheetsSQLDATA2.Cells(1, 1)
    OldRazdel = Razdel
    'выбор раздела
    With sheetsService
        .Range(.Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN), .Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN + KRIT_RAZDEL_COLUMNCOUNT - 1)) = ""
        .Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN) = VBA.Trim(IIf(Razdel = 0, 1, Razdel))
        .Cells(KRIT_RAZDEL_ROW + 3, KRIT_RAZDEL_COLUMN).CALCULATE
        Worksheets(VBA.Trim(.Cells(KRIT_RAZDEL_ROW + 3, KRIT_RAZDEL_COLUMN))).Activate
        Set sheetsReport = Sheets(VBA.Trim(.Cells(KRIT_RAZDEL_ROW + 3, KRIT_RAZDEL_COLUMN)))
        .Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN) = ""
    End With
    row = 1
    
    codeCol = sheetsReport.Range("CODE_STR").Column
    For i = 1 To lineCount
        lnk = sheetsReport.Cells(i - 1 + sheetsService.Range("C5"), 1).Value
        If lnk <> 0 Then
            linkArr(i) = i - 1 + sheetsService.Range("C5")
            codeArr(i) = VBA.Trim(sheetsReport.Cells(i - 1 + sheetsService.Range("C5"), codeCol))
            If codeArr(i) = "800000" Then itogStr = linkArr(i)
        End If
    Next
    
    sheetsService.Range("A37") = 1
'    Sheets("Контроль").Visible = True
    GoTo rrr
    Do While sheetsSQLDATA2.Cells(row, 1).Text <> ""
    
        If (Razdel <> sheetsSQLDATA2.Cells(row, 1)) _
            Or (div <> sheetsSQLDATA2.Cells(row, 3)) _
            Or (dep <> sheetsSQLDATA2.Cells(row, 4)) _
            Or (tgt <> sheetsSQLDATA2.Cells(row, 5)) _
            Or (exp <> sheetsSQLDATA2.Cells(row, 6)) _
        Then ' создать запись
            If sheetsSQLDATA2.Cells(row, 7) <> "999999" Then
                If Razdel <> sheetsSQLDATA2.Cells(row, 1) Then
                    'смена листа
                    With sheetsService
                        .Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN) = VBA.Trim(sheetsSQLDATA2.Cells(row, 1))
                        Worksheets(VBA.Trim(.Cells(KRIT_RAZDEL_ROW + 3, KRIT_RAZDEL_COLUMN))).Activate
                        Set sheetsReport = Sheets(VBA.Trim(.Cells(KRIT_RAZDEL_ROW + 3, KRIT_RAZDEL_COLUMN)))
                        .Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN) = ""
                        
                        lineCount = sheetsService.Range("A9") - sheetsService.Range("C5") + 1
                        ReDim codeArr(lineCount)
                        ReDim linkArr(lineCount)
                        For i = 1 To lineCount
                            lnk = sheetsReport.Cells(i - 1 + sheetsService.Range("C5"), 1).Value
                            If lnk <> 0 Then
                                linkArr(i) = i - 1 + sheetsService.Range("C5")
                                codeArr(i) = VBA.Trim(sheetsReport.Cells(i - 1 + sheetsService.Range("C5"), codeCol))
                                If codeArr(i) = "800000" Then itogStr = linkArr(i)
                            End If
                        Next
                        
                    End With
                    
                    Call addHead
                    Razdel = sheetsSQLDATA2.Cells(row, 1)
                    OldRazdel = Razdel
                End If
                Set LookRange = Sheets("Контроль").Range("A2:A60000").Find("", LookIn:=xlFormulas, lookat:=xlWhole, SearchOrder:=xlByRows)
                Sheets("Контроль").Cells(LookRange.row, colControl) = "Контроль раздела " + Razdel + ", подраздел " + div + ", ведомство " + dep + ", цел. статья " + tgt + ", вид расхода " + exp
                Sheets("Контроль").Range(Sheets("Контроль").Cells(LookRange.row, colControl), Sheets("Контроль").Cells(LookRange.row, colControl + 4)).Interior.ColorIndex = 6
                
                Application.Names.Add name:="CODE_STR_CONTROL", RefersTo:="=Контроль!$B$" + VBA.Trim(VBA.str(LookRange.row + 1)) + ":$B$60000"
                
                Set LookRange = Nothing
                
                Call CONTROL_PAGE_FROM_FILE
                If sheetsService.Range("A59") = 0 Then
                    errorFlag = True
                End If
                
                sheetsReport.Range("MAIN_DATA") = ""
                'sheetsReport.Range("MAIN_DATA").Interior.ColorIndex = xlColorIndexAutomatic
                'Razdel = sheetsSQLDATA2.Cells(row, 1)
                div = sheetsSQLDATA2.Cells(row, 3)
                dep = sheetsSQLDATA2.Cells(row, 4)
                tgt = sheetsSQLDATA2.Cells(row, 5)
                exp = sheetsSQLDATA2.Cells(row, 6)
                OldBK = div + ", " + dep + ", " + tgt + ", " + exp

                GoTo rrr
            End If
        Else
rrr:
        If sheetsSQLDATA2.Cells(row, 7) = "" Then sheetsSQLDATA2.Cells(row, 7) = sheetsSQLDATA2.Cells(row - 1, 7)
        For i = 1 To lineCount
            If codeArr(i) = VBA.Trim(sheetsSQLDATA2.Cells(row, 7)) Then
                For j = 1 To sheetsService.Range("A10")
                    sheetsReport.Cells(linkArr(i), sheetsService.Range("C6") + j - 1).Value = VBA.Val(sheetsSQLDATA2.Cells(row, 7 + j))
                Next
                If codeArr(i) <> "800000" Then pUPDColl(Razdel).Add (VBA.str(linkArr(i)))
                GoTo ttt
            End If
        Next
ttt:
        End If
        row = row + 1
    Loop
    
     Set LookRange = Sheets("Контроль").Range("A2:A60000").Find("", LookIn:=xlFormulas, lookat:=xlWhole, SearchOrder:=xlByRows)
    Sheets("Контроль").Cells(LookRange.row, colControl) = "Контроль раздела " + Razdel + ", подраздел " + div + ", ведомство " + dep + ", цел. статья " + tgt + ", вид расхода " + exp
    Sheets("Контроль").Range(Sheets("Контроль").Cells(LookRange.row, colControl), Sheets("Контроль").Cells(LookRange.row, colControl + 4)).Interior.ColorIndex = 6
    
    Application.Names.Add name:="CODE_STR_CONTROL", RefersTo:="=Контроль!$B$" + VBA.Trim(VBA.str(LookRange.row + 1)) + ":$B$60000"
    
    Set LookRange = Nothing
   
    Call CONTROL_PAGE_FROM_FILE
    If sheetsService.Range("A59") = 0 Then
        errorFlag = True
    End If
    
    Print #2, ""
    ' Установка флага конца операции
    If errorFlag Then
        Sheets("Service").Range("A59") = 1
        Print #2, " - обнаружены ошибки контроля "
    Else
        Sheets("Service").Range("A59") = 0
        Print #2, " - ошибок контроля не обнаружено "
    End If
    
    Print #2, "------------------------------------------------------------"
   
'LockWindowUpdate (0)
End Sub

'добавляет итоговые строки (80000) для форм 614(714) в SQLDATA2
Sub ADD_ITOG_STR()
Dim sum(3) As Double, rowData As Integer, sheetsSQLDATA2, flag As Boolean
Dim c1 As String, c2 As String, c3 As String, c4 As String, Razdel As Integer, i As Integer

    rowData = 1
    For i = 1 To 3
        sum(i) = 0
    Next
    
    'Stop
    Set sheetsSQLDATA2 = Sheets("SQLDATA2")
    
    'читаем текущую БК
    c1 = VBA.Trim(sheetsSQLDATA2.Cells(rowData, 3))
    c2 = VBA.Trim(sheetsSQLDATA2.Cells(rowData, 4))
    c3 = VBA.Trim(sheetsSQLDATA2.Cells(rowData, 5))
    c4 = VBA.Trim(sheetsSQLDATA2.Cells(rowData, 6))
    Razdel = sheetsSQLDATA2.Cells(rowData, 1)
    
    While (VBA.Trim(sheetsSQLDATA2.Cells(rowData, 1)) <> "")
        If (c1 <> VBA.Trim(sheetsSQLDATA2.Cells(rowData, 3))) Or _
            (c2 <> VBA.Trim(sheetsSQLDATA2.Cells(rowData, 4))) Or _
            (c3 <> VBA.Trim(sheetsSQLDATA2.Cells(rowData, 5))) Or _
            (c4 <> VBA.Trim(sheetsSQLDATA2.Cells(rowData, 6))) Or _
            (Razdel <> sheetsSQLDATA2.Cells(rowData, 1)) Then
                sheetsSQLDATA2.Rows(rowData).Insert
                sheetsSQLDATA2.Cells(rowData, 3) = c1
                sheetsSQLDATA2.Cells(rowData, 4) = c2
                sheetsSQLDATA2.Cells(rowData, 5) = c3
                sheetsSQLDATA2.Cells(rowData, 6) = c4
                sheetsSQLDATA2.Cells(rowData, 7) = "800000"
                sheetsSQLDATA2.Cells(rowData, 1) = Razdel
                
                For i = 1 To IIf(Razdel = 1, 3, 1)
                    sheetsSQLDATA2.Cells(rowData, 7 + i) = VBA.str(sum(i))
                    sum(i) = 0
                Next
                
                rowData = rowData + 1
                
                c1 = VBA.Trim(sheetsSQLDATA2.Cells(rowData, 3))
                c2 = VBA.Trim(sheetsSQLDATA2.Cells(rowData, 4))
                c3 = VBA.Trim(sheetsSQLDATA2.Cells(rowData, 5))
                c4 = VBA.Trim(sheetsSQLDATA2.Cells(rowData, 6))
                Razdel = sheetsSQLDATA2.Cells(rowData, 1)
                
                GoTo sss
            Else
sss:
                For i = 1 To IIf(Razdel = 1, 3, 1)
                    sum(i) = sum(i) + VBA.Val(sheetsSQLDATA2.Cells(rowData, 7 + i))
                Next
            End If
        rowData = rowData + 1
    Wend

End Sub

Sub after_output_f605()

End Sub

