Attribute VB_Name = "repmaker"
'
' 22.09.2006 Учет настройки "Черно-белая печать"
' 07.07.2004 Возможность печатать более 50 групп, получать значение предыдущей группы
' 11.03.2004 Добавлен скроллинг на ячейку [a1]
' 10.03.2004 Подправления Титова
' 10.02.2004 В ячейке [K1] можно указать поле, по которому, будут обзываться листы
' 27.03.2002 добавлено автосохранение
' 09.12.2002 сортировка в совокупности с группами
'
Option Private Module
Option Explicit
Public repPath As String, repName As String, Er As Integer, lnLastRowsCount As Long, _
       dbPath As String, dbSelect As String, dbSelectGroup As String, lcAddParam As String, lcAddModule As String, _
       wsd As Object, wso As Object, wsr As Object, wsh As Object, _
       rCurRow As Range, rStartRow As Range, rEndRow As Range, rGroupOrderRange As Range, rCurentRange As Range, _
       lnBits As Byte, SheetFieldName As String, lcAddModuleFunc As String, lcAddModuleFuncArg As String, _
       rStartGroup As Range, rEndGroup As Range, _
       columnsCount As Integer, rowsCount As Long, groupCount As Integer, _
       curPosD As Long, curPosR As Long, curGroup As Integer, _
       gFPosR(51) As String, gbFPosR(51) As Boolean, _
       gStartPosD(51) As Long, gEndPosD(51) As Long, _
       gStartPosH(51) As Long, gEndPosH(51) As Long, _
       gStartPosF(51) As Long, gEndPosF(51) As Long, _
       SheetsNames(1023) As String, _
       gStartPosDet As Long, gEndPosDet As Long, _
       gVal(51), nl As Integer, lnCount As Long, lnOldDisplayZeros As Boolean, _
       nxlFreezePanes As Boolean, nxlPages As Boolean, nxlDateTime As Boolean, _
       nxlLeftHeader As String, nxlCenterHeader As String, nxlRightHeader As String, _
       DataStartRow As Long, GroupStartRow As Long, HideDetail As Boolean, _
       lcWsoName As String, _
       cAutoSaveName As String, cAutoSavePath As String, _
       lcAddModuleFunc2 As String, lcAddModuleFuncArg2 As String, lbStat As Boolean, _
       dTime1 As Date, dTime2 As Date, nTimeDiff As Integer, dTimeBegin As Date, dTimePage As Date, dTimeAllPage As Date, _
       lcLogFile As String, lnLogMode As Integer, lnComCount As Long, _
       groupProp(51, 15) '0-поле, 1-столбец, 2-нов.лист, 3-нов.страница, 4-символы гр., 5-скв.строки, 6-закрепление области
'добавлено 07.07.2004
Public rStartPredGroup As Range, rEndPredGroup As Range, nStartPredGroup As Long, nEndPredGroup As Long, _
       rPredGroupValue As Range, cPredGroupValue As String, _
       rPredGroupName As Range
'добавлено 19.07.2005
Public LFooter As String, CFooter As String, RFooter As String, bCalcFooter As Boolean

'добавлено 22.09.2006
Public lbBlackAndWhite As Boolean
      

Sub MakeReport()
Dim ws As Object, lcString As String, lnPos As Integer, c As Range, _
    d1 As Date, d2 As Date, d As Date, i As Long, j As Long, _
    lcField As String, lcRepSheets As String, lnRepSheet As Integer, _
    lcStringOrder As String, nRet As Integer

    lbStat = True                       ' писать статистику
    lcLogFile = "c_repmaker.log"        ' файл статистики
    lnLogMode = 1                       ' 0 - создавать файл заново, 1 - добавлять

    DataStartRow = 10
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
    repPath = Trim(ThisWorkbook.Sheets(1).[a2].Value)
    repPath = repPath + IIf(repPath <> "", IIf(Mid(repPath, Len(repPath), 1) = "\", "", "\"), "")
    repName = Trim(ThisWorkbook.Sheets(1).[B2].Value)
    dbPath = Trim(ThisWorkbook.Sheets(1).[C2].Value)
    If dbPath <> "" Then
        dbPath = dbPath + IIf(Mid(dbPath, Len(dbPath), 1) = "\", "", "\")
    End If
    dbSelect = Trim(ThisWorkbook.Sheets(1).[d2].Value)
    nxlFreezePanes = ThisWorkbook.Sheets(1).[G2].Value
    nxlPages = ThisWorkbook.Sheets(1).[H2].Value
'    nxlDateTime = ThisWorkbook.Sheets(1).[I2].Value
    nxlLeftHeader = ThisWorkbook.Sheets(1).[K2].Value
    nxlCenterHeader = ThisWorkbook.Sheets(1).[L2].Value
    nxlRightHeader = ThisWorkbook.Sheets(1).[M2].Value

    cAutoSavePath = ThisWorkbook.Sheets(1).[n2].Value
    If cAutoSavePath <> "" Then
        cAutoSavePath = cAutoSavePath + IIf(Mid(cAutoSavePath, Len(cAutoSavePath), 1) = "\", "", "\")
    End If
    cAutoSaveName = ThisWorkbook.Sheets(1).[O2].Value
    lbBlackAndWhite = ThisWorkbook.Sheets(1).[P2].Value

    lcAddParam = Trim(ThisWorkbook.Sheets(1).[f2].Value)
    lcAddModule = GetStrParam(lcAddParam, 3)
    If lcAddModule <> "" Then
        nRet = AddModule(Application.ThisWorkbook, Application.ThisWorkbook.Path + "\MODULES\", lcAddModule)
    End If
    lnBits = Val(GetStrParam(lcAddParam, 1))
'    If (lnBits And 1) > 0 Then
'        Call MinimizeWindow
'    End If
    SheetFieldName = GetStrParam(lcAddParam, 2)
    lcAddModuleFunc = GetStrParam(lcAddParam, 4)
    lcAddModuleFuncArg = GetStrParam(lcAddParam, 5)


    If lbStat Then
        lcLogFile = dbPath + lcLogFile
        Call PrintFile(lcLogFile, lnLogMode, "")
        Call PrintFile(lcLogFile, 1, "Формирование отчета " & repPath & repName)
        dTime1 = Time()
        dTimeBegin = dTime1
     End If

    ' Открываем шаблон документа
    Workbooks.Open fileName:=repPath + repName
    ActiveWindow.ScrollColumn = 1
    ActiveWindow.ScrollRow = 1
    Range("A1").Select

    If lbStat Then
        dTime2 = Time()
        nTimeDiff = DateDiff("s", dTime1, dTime2)
        dTime1 = dTime2
        Call PrintFile(lcLogFile, 1, "  " & nTimeDiff & " сек - Открытие шаблона")
    End If

    Set wso = Application.ActiveWorkbook.ActiveSheet
    lnOldDisplayZeros = Application.ActiveWindow.DisplayZeros
    Application.ActiveWindow.DisplayZeros = True




    ' Добавляем модуль FUNCTIONS.BAS исправлено 10.03.2004 Титов
    nRet = AddModule(Application.ActiveWorkbook, Application.ThisWorkbook.Path + "\MODULES\", "function.bas")
    ' Добавили лист для данных
    Application.ActiveWorkbook.Worksheets.Add
    Set wsd = Application.ActiveWorkbook.ActiveSheet
    wsd.Name = "Данные"

    If lbStat Then
        dTime2 = Time()
        nTimeDiff = DateDiff("s", dTime1, dTime2)
        dTime1 = dTime2
        Call PrintFile(lcLogFile, 1, "  " & nTimeDiff & " сек - Импорт модуля function.bas")
    End If

    lcRepSheets = ""
    ' Добавляем группы из листа "Группы"
    For Each ws In Application.ActiveWorkbook.Worksheets
        If ws.Name = "Группы" Then
            lcString = ws.Cells(1, 1).Value
            Set c = ws.Cells(LastCell(ws.Cells).Row + 1, 1)
            Call LoadTable(c, lcString)
            lcStringOrder = wso.[f1]
            lcString = ""
            
            gEndPosH(0) = 0       ' Конечная строка шапки группы
            groupCount = ws.Cells(1, 2)
            For i = 1 To groupCount
                gStartPosH(i) = gEndPosH(i - 1) + 2 ' Начальная строка шапки группы
                gEndPosH(i) = gEndPosH(i - 1) + 1
                Do While Not (ws.Cells(gEndPosH(i) + 1, 1).Value Like "^ Шапка*")
                    gEndPosH(i) = gEndPosH(i) + 1
                Loop
                groupProp(i, 0) = ws.Cells(gEndPosH(i) + 1, 2).Value
            Next i
            
            gEndPosF(groupCount + 1) = gEndPosH(groupCount) ' Конечная строка концовки группы
            For i = groupCount To 1 Step -1
                gStartPosF(i) = gEndPosF(i + 1) + 2 ' Начальная строка концовки группы
                gEndPosF(i) = gEndPosF(i + 1) + 1
                Do While Not (ws.Cells(gEndPosF(i) + 1, 1).Value Like "^ Концовка*")
                    gEndPosF(i) = gEndPosF(i) + 1
                Loop
            Next i
            
            gEndPosDet = wso.Cells.Find("^ Данные", LookIn:=xlValues, LookAt:=xlWhole).Row
            gStartPosDet = gEndPosDet
            Do While Not (wso.Cells(gStartPosDet - 1, 1).Value Like "^ Шапка*")
                gStartPosDet = gStartPosDet - 1
            Loop

            For i = 1 To rowsCount
                lcField = c.Offset(i - 1, 0).Value
                lcString = lcString + IIf(lcString = "", "", ", ") + lcField
                j = 1
                If c.Offset(i - 1, 3).Value = "" Or c.Offset(i - 1, 3).Value = 1 Then
                    Do While (Not UCase(groupProp(j, 0)) = UCase(lcField)) And (j <= groupCount)
                        j = j + 1
                    Loop
                    If j <= groupCount Then
                        ws.Rows(Trim(Str(gStartPosH(j))) + ":" + Trim(Str(gEndPosH(j) + 1))).Copy
                        wso.Rows(gStartPosDet).Insert Shift:=xlDown
                        gStartPosDet = gStartPosDet + (gEndPosH(j) - gStartPosH(j) + 2)
                        gEndPosDet = gEndPosDet + (gEndPosH(j) - gStartPosH(j) + 2)
                        ws.Rows(Trim(Str(gStartPosF(j))) + ":" + Trim(Str(gEndPosF(j) + 1))).Copy
                        wso.Rows(gEndPosDet + 1).Insert Shift:=xlDown
                        wso.[B1] = wso.[B1] + 1
                    End If
                End If
            Next i
            If lcStringOrder <> "" Then
                lcString = lcString + IIf(lcString = "", "", ", ") + lcStringOrder
            End If
            If ws.[f1] <> "" Then
                lcString = ws.[f1] + IIf(lcString = "", "", ", ") + lcString
            End If
            wso.[f1] = lcString
            wso.Activate
            ws.Delete

            If lbStat Then
                dTime2 = Time()
                nTimeDiff = DateDiff("s", dTime1, dTime2)
                dTime1 = dTime2
                Call PrintFile(lcLogFile, 1, "  " & nTimeDiff & " сек - Добавление группировки")
            End If
        Else
            If ws.Visible = True Then lcRepSheets = lcRepSheets + ws.Name + "#"
        End If
    Next ws
    Set ws = Nothing
    Set c = Nothing

    Call LoadNastr(wsd.[a1])
    wso.Cells.Calculate

    lcString = wso.[K1]
    If SheetFieldName = "" And lcString <> "" Then
        SheetFieldName = lcString
    End If

'    wso.[C1].Calculate
'    wso.[d1].Calculate
'    wso.[E1].Calculate
'    wso.[f1].Calculate



    lcString = wso.[C1]
    If lcString <> "" Then
        lnPos = InStr(1, dbSelect, "SELECT", 1)
        If lnPos > 0 Then
            dbSelect = Mid(dbSelect, 1, lnPos + 6) + lcString + ", " + Mid(dbSelect, lnPos + 7)
        End If
    End If

    lcString = wso.[d1]
    If lcString <> "" Then
        lnPos = InStr(1, dbSelect, "FROM", 1)
        If lnPos > 0 Then
            dbSelect = Mid(dbSelect, 1, lnPos + 4) + lcString + ", " + Mid(dbSelect, lnPos + 5)
        End If
    End If

    lcString = wso.[E1]
    If lcString <> "" Then
        lnPos = InStr(1, dbSelect, "WHERE", 1)
        If lnPos > 0 Then
            dbSelect = Mid(dbSelect, 1, lnPos + 5) + lcString + " AND " + Mid(dbSelect, lnPos + 6)
        Else
            lnPos = InStr(1, dbSelect, "ORDER BY", 1)
            If lnPos > 0 Then
                dbSelect = Mid(dbSelect, 1, lnPos - 1) + " WHERE " + lcString + " " + Mid(dbSelect, lnPos)
            Else
                dbSelect = dbSelect + " WHERE " + lcString
            End If
        End If
    End If

    lcString = wso.[f1]
        If SheetFieldName <> "" Then
            lcString = SheetFieldName + IIf(lcString <> "", ", " + lcString, "")
        End If
    If lcString <> "" Then
        lnPos = InStr(1, dbSelect, "ORDER BY", 1)
        If lnPos > 0 Then
            dbSelect = Mid(dbSelect, 1, lnPos - 1) + " ORDER BY " + lcString
        Else
            dbSelect = dbSelect + " ORDER BY " + lcString
        End If
    End If


    If lbStat Then
        dTime2 = Time()
        nTimeDiff = DateDiff("s", dTime1, dTime2)
        dTime1 = dTime2
        Call PrintFile(lcLogFile, 1, "  " & nTimeDiff & " сек - Загрузка настроек")
    End If

    DataStartRow = 10 + rowsCount

    ' Загружаем данные
    Er = 0
    Call LoadData

    If lbStat Then
        dTime2 = Time()
        nTimeDiff = DateDiff("s", dTime1, dTime2)
        dTime1 = dTime2
        Call PrintFile(lcLogFile, 1, "  " & nTimeDiff & " сек - Загрузка данных")
    End If

    If Er = 0 Then
        lnRepSheet = 1
        While GetStrParam(lcRepSheets, lnRepSheet) <> ""
            lcWsoName = GetStrParam(lcRepSheets, lnRepSheet)
            If lcWsoName <> "Данные" Then
                Set wso = ActiveWorkbook.Worksheets(lcWsoName)
                lcAddModuleFunc2 = wso.[H1]
                lcAddModuleFuncArg2 = wso.[I1]
                ' Преобразование полей
                Application.StatusBar = "Подготовка к формированию отчета..."
                Call DubleRows(wso.Range(wso.[a1], LastCell(wso.[a1])))

                If lbStat Then
                    dTime2 = Time()
                    nTimeDiff = DateDiff("s", dTime1, dTime2)
                    dTime1 = dTime2
                    Call PrintFile(lcLogFile, 1, "  " & nTimeDiff & " сек - Дублирование строк")
                End If

                Call f1
                lnLastRowsCount = wso.[g1]

                If lbStat Then
                    dTime2 = Time()
                    nTimeDiff = DateDiff("s", dTime1, dTime2)
                    dTime1 = dTime2
                    Call PrintFile(lcLogFile, 1, "  " & nTimeDiff & " сек - Подготовка групп")
                End If

                Call ValuesColumns(wso.Range(wso.[a1], LastCell(wso.[a1])))

                If lbStat Then
                    dTime2 = Time()
                    nTimeDiff = DateDiff("s", dTime1, dTime2)
                    dTime1 = dTime2
                    Call PrintFile(lcLogFile, 1, "  " & nTimeDiff & " сек - Размножение столбцов по значениям")
                End If

                Call DubleColumns(wso.Range(wso.[a1], LastCell(wso.[a1])))

                If lbStat Then
                    dTime2 = Time()
                    nTimeDiff = DateDiff("s", dTime1, dTime2)
                    dTime1 = dTime2
                    Call PrintFile(lcLogFile, 1, "  " & nTimeDiff & " сек - Дублирование столбцов")
                End If

                Call f1_2
                
'добавлено 19.07.2005
                On Error GoTo PErr1
                wso.Cells(gEndPosF(1) + 1, 10) = wso.PageSetup.LeftFooter
                wso.Cells(gEndPosF(1) + 1, 11) = wso.PageSetup.CenterFooter
                wso.Cells(gEndPosF(1) + 1, 12) = wso.PageSetup.RightFooter
PErr1:          On Error GoTo 0
                bCalcFooter = True
                
                Call RedefineFields(wso.Range(wso.[a1], LastCell(wso.[a1])))

'добавлено 19.07.2005
                LFooter = wso.Cells(gEndPosF(1) + 1, 10).FormulaLocal
                CFooter = wso.Cells(gEndPosF(1) + 1, 11).FormulaLocal
                RFooter = wso.Cells(gEndPosF(1) + 1, 12).FormulaLocal

                If lbStat Then
                    dTime2 = Time()
                    nTimeDiff = DateDiff("s", dTime1, dTime2)
                    dTime1 = dTime2
                    Call PrintFile(lcLogFile, 1, "  " & nTimeDiff & " сек - Подготовка формул")
                End If

                ' Формирование отчета
                Application.StatusBar = "Формирование документа (0%)"
                ' Создание нового листа
                Sheets(lcWsoName).Copy Before:=Sheets(1)
                Application.ActiveSheet.Name = lcWsoName + " (1)"
                Set wsr = Application.ActiveSheet
                wsr.Rows("1:10000").Delete Shift:=xlUp
'Удаление ненужных картинок
                For i = wsr.Shapes.Count To 1 Step -1
                    wsr.Shapes(i).Delete
                Next i
                If SheetFieldName <> "" Then
                    wsd.Activate
                    Set c = wsd.Range(Cells(DataStartRow - 1, 1), Cells(DataStartRow - 1, columnsCount)).Find(SheetFieldName, LookIn:=xlValues, LookAt:=xlWhole)
                    If Not c Is Nothing Then

'Изменение формирования имен листов для пакетной выгрузки
                        If Not (wsd.Cells(DataStartRow, c.Column) Like "[#]*[#]*[#]*") And wsd.Cells(DataStartRow, c.Column) <> "" Then
                            wsr.Name = Left(wsd.Cells(DataStartRow, c.Column), 31)
                        End If
                        SheetsNames(wsr.Index) = wsd.Cells(DataStartRow, c.Column)

                    End If
                    wsr.Activate
                End If
                On Error GoTo ErrP1
                With ActiveSheet.PageSetup
                     If lbBlackAndWhite Then
                        .BlackAndWhite = True
                     End If
                    .LeftHeader = "&8" & nxlLeftHeader
                    .CenterHeader = "&8" & nxlCenterHeader
                    .RightHeader = "&8" & nxlRightHeader
                End With
ErrP1:          On Error GoTo 0
                curPosR = 1
                d1 = Now()

                If lbStat Then
                    dTime2 = Time()
                    nTimeDiff = DateDiff("s", dTime1, dTime2)
                    dTime1 = dTime2
                End If

                Call f2(1)

                If lbStat Then
                    dTime2 = Time()
                    nTimeDiff = DateDiff("s", dTime1, dTime2)
                    dTime1 = dTime2
                    Call PrintFile(lcLogFile, 1, "  " & nTimeDiff & " сек - Формирование листов отчета")
                End If

                Call AutoFitRows

                If lbStat Then
                    dTime2 = Time()
                    nTimeDiff = DateDiff("s", dTime1, dTime2)
                    dTime1 = dTime2
                    Call PrintFile(lcLogFile, 1, "  " & nTimeDiff & " сек - Автоподбор высоты строк")
                End If

                d2 = Now()
        '        MsgBox (DateDiff("s", d1, d2) & " сек")
                Application.DisplayAlerts = False
    '*****************   Винокуров Андрей, 26.09.2002
                ' Добавляем дополнительные модули (ячейка H1)
                i = 1
                While GetStrParam(lcAddModuleFunc2, i) <> ""
                    lcString = VBA.Trim(GetStrParam(lcAddModuleFunc2, i))
                    If StrConv(lcString, vbUpperCase) <> "REPMAKER.BAS" Then
                        nRet = AddModule(Application.ThisWorkbook, repPath + "MODULES\", lcString)
                    End If
                    i = i + 1
                Wend
                ' Выполняем дополнительные функции (ячейка I1)
                i = 1
                While GetStrParam(lcAddModuleFuncArg2, i) <> ""
                    lcString = GetStrParam(lcAddModuleFuncArg2, i + 1)
                    j = Len(lcString) - Len(StrReplace(lcString, ",", ""))
                    lcString = StrReplace(lcString, ",", "#")
                    Select Case j
                    Case 4
                        j = Application.Run(GetStrParam(lcAddModuleFuncArg2, i), GetStrParam(lcString, 1), GetStrParam(lcString, 2), GetStrParam(lcString, 3), GetStrParam(lcString, 4), GetStrParam(lcString, 5))
                    Case 3
                        j = Application.Run(GetStrParam(lcAddModuleFuncArg2, i), GetStrParam(lcString, 1), GetStrParam(lcString, 2), GetStrParam(lcString, 3), GetStrParam(lcString, 4))
                    Case 2
                        j = Application.Run(GetStrParam(lcAddModuleFuncArg2, i), GetStrParam(lcString, 1), GetStrParam(lcString, 2), GetStrParam(lcString, 3))
                    Case 1
                        j = Application.Run(GetStrParam(lcAddModuleFuncArg2, i), GetStrParam(lcString, 1), GetStrParam(lcString, 2))
                    Case Else
                        If lcString <> "" Then
                            j = Application.Run(GetStrParam(lcAddModuleFuncArg2, i), lcString)
                        Else
                            j = Application.Run(GetStrParam(lcAddModuleFuncArg2, i))
                        End If
                    End Select
                    i = i + 2
                Wend
    '*****************   конец
                If lbStat Then
                    dTime2 = Time()
                    nTimeDiff = DateDiff("s", dTime1, dTime2)
                    dTime1 = dTime2
                    Call PrintFile(lcLogFile, 1, "  " & nTimeDiff & " сек - Дополнительные действия")
                    dTimeAllPage = dTime1
                End If

                wso.Delete
            End If
            lnRepSheet = lnRepSheet + 1
        Wend

        ' Создаем свою панель инструментов
        Call InitCBR
        wsd.Delete
        lnPos = 1
        Application.StatusBar = "Подготовка листов (0%)"
        For Each ws In Application.ActiveWorkbook.Worksheets
            ws.Activate

            If lbStat Then
                dTime2 = Time()
                nTimeDiff = DateDiff("s", dTime1, dTime2)
                dTime1 = dTime2
                dTimePage = dTime1
            End If

            Call HideColumn

            If lbStat Then
                dTime2 = Time()
                nTimeDiff = DateDiff("s", dTime1, dTime2)
                dTime1 = dTime2
                Call PrintFile(lcLogFile, 1, "    " & nTimeDiff & " сек - Скрытие лишних колонок")
            End If

            Application.ActiveWindow.DisplayZeros = lnOldDisplayZeros
            Call SetPageHeight

            If lbStat Then
                dTime2 = Time()
                nTimeDiff = DateDiff("s", dTime1, dTime2)
                dTime1 = dTime2
                Call PrintFile(lcLogFile, 1, "    " & nTimeDiff & " сек - Подгон масштаба станицы")
            End If

            Call SetLastRowsCount(lnLastRowsCount)

            If lbStat Then
                dTime2 = Time()
                nTimeDiff = DateDiff("s", dTime1, dTime2)
                dTime1 = dTime2
                Call PrintFile(lcLogFile, 1, "    " & nTimeDiff & " сек - Вставка разрыва страницы от висячих строк")
            End If

            ActiveWindow.ScrollRow = 1
            [a1].Select
            Application.StatusBar = "Подготовка листов (" & Int(lnPos * 100 / Application.ActiveWorkbook.Worksheets.Count) & "%)"
            lnPos = lnPos + 1
            If lcAddModuleFunc <> "" Then
                j = Run(lcAddModuleFunc, lcAddModuleFuncArg)
            End If
            i = 6
            While GetStrParam(lcAddParam, i) <> ""
                j = Run(GetStrParam(lcAddParam, i), GetStrParam(lcAddParam, i + 1))
                i = i + 2
            Wend

            If lbStat Then
                dTime2 = Time()
                nTimeDiff = DateDiff("s", dTime1, dTime2)
                dTime1 = dTime2
                Call PrintFile(lcLogFile, 1, "    " & nTimeDiff & " сек - Выполнение дополнительных функций дополнительных модулей")
                Call PrintFile(lcLogFile, 1, "    Всего на подготовку листа " & ws.Name & ": " & DateDiff("s", dTimePage, dTime2) & " сек")
            End If
        Next ws
    Else
        Application.DisplayAlerts = False
        wso.Parent.Close
    End If

    If lbStat Then
        dTime2 = Time()
        Call PrintFile(lcLogFile, 1, "  Всего подготовка листов: " & DateDiff("s", dTimeAllPage, dTime2) & " сек")
        dTime1 = dTime2
    End If

    If cAutoSaveName <> "" Then
        If cAutoSavePath = "" Then
            cAutoSavePath = dbPath
        End If
        On Error Resume Next
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs fileName:=cAutoSavePath + cAutoSaveName, FileFormat:= _
            xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
            , CreateBackup:=False
        Application.DisplayAlerts = True
        On Error GoTo 0
        If lbStat Then
            dTime2 = Time()
            nTimeDiff = DateDiff("s", dTime1, dTime2)
            dTime1 = dTime2
            Call PrintFile(lcLogFile, 1, "  " & nTimeDiff & " сек - Автосохранение в каталог " & cAutoSavePath)
        End If
    End If

    If lbStat Then
        Call PrintFile(lcLogFile, 1, "Всего на создание отчета: " & DateDiff("s", dTimeBegin, dTime2) & " сек")
    End If

    Application.ActiveWorkbook.Sheets(1).Activate
    Application.StatusBar = False
    Application.DisplayAlerts = True
    Application.Visible = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.ActiveWorkbook.Saved = True
    Application.ThisWorkbook.Windows(1).Visible = False
    Application.ThisWorkbook.Saved = True

'    If (lnBits And 1) = 0 Then
'        Call NormalizeWindow
'    End If
    If (lnBits And 2) > 0 Then
        Application.ActiveWorkbook.Close
        Application.ThisWorkbook.Close
    End If
End Sub



Sub AutoFitRows()
Dim Com As Comment, ws As Object, rRange As Range
    Application.StatusBar = "Подбор высоты строк..."
    For Each ws In Application.ActiveWorkbook.Worksheets

        Set rRange = Nothing
        If ws.Comments.Count > 0 Then
            ws.Activate
            For Each Com In ws.Comments
                If Not Com.Parent.MergeCells Then
                    If Com.Text = "Eval" Then
                       Com.Parent.FormulaLocal = "=" + Mid(Com.Parent.Value, 5)
                       Com.Delete
                    Else
                       If Com.Text = "Fit" Then
                           If rRange Is Nothing Then Set rRange = Com.Parent.EntireRow Else Set rRange = Union(rRange, Com.Parent.EntireRow)
                           Com.Delete
                       End If
                    End If
                End If
            Next Com
        End If
        If Not rRange Is Nothing Then rRange.EntireRow.AutoFit

        If ws.Comments.Count > 0 Then
            ws.Activate
            For Each Com In ws.Comments
                If Com.Text = "Eval" Then
                    Com.Parent.FormulaLocal = "=" + Mid(Com.Parent.Value, 5)
                    Com.Delete
                Else
                    If Com.Text = "Fit" Then
                        Call AutoFitRow(Com.Parent)
                        Com.Delete
                    End If
                End If
            Next Com
        End If
    Next ws
    Set rRange = Nothing
End Sub

Sub MinimizeWindow()
    Application.WindowState = xlMinimized
End Sub

Sub NormalizeWindow()
    Application.WindowState = xlMinimized
    Application.WindowState = xlNormal
End Sub

Sub InitCBR()
    ' Удаляем старую панель
    Call DeleteCBR("Печать")
    ' Добавляем новую панель
    Application.CommandBars.Add(Name:="Печать", Position:=msoBarTop, Temporary:=True).Visible = True
    Application.CommandBars("Печать").Controls.Add Type:=msoControlButton, ID:= _
        109, Before:=1
    With Application.CommandBars("Печать").Controls.Add(Type:=msoControlButton, ID:= _
        2521, Before:=2)
        .Caption = "Печать текущего документа"
    End With
    With Application.CommandBars("Печать").Controls.Add(Type:=msoControlButton, _
        Before:=3)
        .FaceId = 160
        .Style = msoButtonIcon
        .Caption = "Печать всех документов"
        .OnAction = "PrintAll"
    End With
End Sub

Sub DeleteCBR(cbrname As String)
Dim Found As Boolean, cbar As Object
    Found = False
    For Each cbar In Application.CommandBars
        If cbar.Name = cbrname Then Found = True
    Next
    If Found Then Application.CommandBars(cbrname).Delete
    Set cbar = Nothing
End Sub

Sub PrintAll()
Dim ws As Object
    For Each ws In Application.ActiveWorkbook.Worksheets
        ws.PrintOut
    Next ws
    Set ws = Nothing
End Sub

Sub LoadData()
Dim startRange As Range, qt As QueryTable, odbcDriver As String, odbcstr As String, n As Integer
    Application.StatusBar = "Загрузка рабочих данных..."
    wsd.Activate
    Set startRange = wsd.Cells(DataStartRow - 1, 1)
    dbPath = IIf(dbPath = "", ThisWorkbook.Path + "\", dbPath)
    
    If LoadVFPData(startRange, dbPath, dbSelect, rowsCount, columnsCount) < 0 Then GoTo Err1

    If rowsCount = 0 Then
        GoTo Err2
    End If
    ' Присвоение имен
    wsd.Parent.Names.Add Name:="Data", _
        RefersToR1C1:="=Данные!R" + Trim(Str(DataStartRow - 1)) + "C1:R" + Trim(Str(rowsCount + DataStartRow - 1)) + "C" + Trim(Str(columnsCount))
    wsd.Parent.Names.Add Name:="DataFields", _
        RefersToR1C1:="=Данные!R" + Trim(Str(DataStartRow - 1)) + "C1:R" + Trim(Str(DataStartRow - 1)) + "C" + Trim(Str(columnsCount))
    wsd.Parent.Names.Add Name:="CurRow", RefersToR1C1:="=Данные!R1C1"
    wsd.Parent.Names.Add Name:="StartRow", RefersToR1C1:="=Данные!R1C2"
    wsd.Parent.Names.Add Name:="EndRow", RefersToR1C1:="=Данные!R1C3"
    wsd.Parent.Names.Add Name:="CurentGroup", RefersToR1C1:="=Данные!R1C4"
    wsd.Parent.Names.Add Name:="GroupOrder", RefersToR1C1:="=Данные!R1C10"
    wsd.Parent.Names.Add Name:="StartData", RefersToR1C1:="=Данные!R1C5"

    For n = 1 To 50
        wsd.Parent.Names.Add Name:="Start" + Trim(Str(n)), RefersToR1C1:="=Данные!R1C" + Trim(Str(10 + n))
        wsd.Parent.Names.Add Name:="End" + Trim(Str(n)), RefersToR1C1:="=Данные!R1C" + Trim(Str(60 + n))
    Next n

    Set rCurRow = wsd.[a1]
    Set rStartRow = wsd.[B1]
    Set rEndRow = wsd.[C1]
    Set rCurentRange = wsd.[d1]
    Set rGroupOrderRange = wsd.[j1]
    Set rStartGroup = wsd.Cells(1, 11)
    Set rEndGroup = wsd.Cells(1, 61)

'добавлено 07.07.2004
    wsd.Parent.Names.Add Name:="StartPred", RefersToR1C1:="=Данные!R1C254"
    wsd.Parent.Names.Add Name:="EndPred", RefersToR1C1:="=Данные!R1C255"
    Set rStartPredGroup = wsd.Cells(1, 254)
    Set rEndPredGroup = wsd.Cells(1, 255)
    wsd.Parent.Names.Add Name:="PrevGroupValue", RefersToR1C1:="=Данные!R1C253"
    Set rPredGroupValue = wsd.Cells(1, 253)

    wsd.Parent.Names.Add Name:="PrevGroupName", RefersToR1C1:="=Данные!R1C252"
    Set rPredGroupName = wsd.Cells(1, 252)

    rPredGroupValue.NumberFormat = "@"
    cPredGroupValue = "#####"
    nStartPredGroup = 0
    rEndPredGroup = 0
    
    wsd.[E1] = DataStartRow
    GoTo ExitProc
Err1:
    wsd.[f1] = dbSelect
    n = MsgBox("Ошибка загрузки данных!", vbCritical + vbOKOnly, "Ошибка")
    Er = -1
    GoTo ExitProc
Err2:
    n = MsgBox("Нет данных для печати!", vbCritical + vbOKOnly, "Ошибка")
    Er = -1
ExitProc:
    Set startRange = Nothing
    Set qt = Nothing
End Sub

Function IsEmptyRange(loRange) As Boolean
    Dim i, llEmpty
    llEmpty = True
    For i = 1 To loRange.Count
        llEmpty = llEmpty And IsEmpty(loRange.Item(i))
    Next i
    IsEmptyRange = llEmpty
End Function

Sub ValuesColumns(curRange As Range)
Dim c As Range, n1 As Integer, n2 As Integer, n3 As Integer, lnRCount As Long, lnCCount As Integer, lcComm As String, _
    lcSelect As String, lcFieldValues As String, lcFieldRepl As String, lcWhat As String, loCell As Range, _
    wsv As Object, qt As QueryTable, lcRepl As String

    Do
        Set c = curRange.Find("&&", LookIn:=xlValues, LookAt:=xlPart)
        If Not c Is Nothing Then
            lcComm = c.Value
            n1 = InStr(1, lcComm, "#")
            n2 = InStr(n1 + 1, lcComm, "#")
            n3 = InStr(n2 + 1, lcComm, "#")
            lcSelect = Mid(lcComm, 3, n1 - 3)
            lcFieldValues = Mid(lcComm, n1 + 1, n2 - n1 - 1)
            lcFieldRepl = Mid(lcComm, n2 + 1, n3 - n2 - 1)
            lcWhat = Mid(lcComm, n3 + 1, Len(lcComm) - n3)


            Application.ActiveWorkbook.Worksheets.Add
            Set wsv = Application.ActiveWorkbook.ActiveSheet

            wsv.Activate
            
            If LoadVFPData(Cells(1, 1), dbPath, lcSelect, lnRCount, lnCCount) < 0 Then GoTo ErrV
            
            n1 = 1 'Столбец поля значений
            n2 = 1 'Столбец поля замены
            For n3 = 1 To lnCCount
                If UCase(Cells(1, n3).Value) = UCase(lcFieldValues) Then n1 = n3
                If UCase(Cells(1, n3).Value) = UCase(lcFieldRepl) Then n2 = n3
            Next n3
            wso.Activate
            For n3 = 1 To lnRCount - 1
                Call Duble(c)
                c.Offset(0, -1).Select
                Set loCell = Selection.Cells(1, 1)
                Call ReplaceMask(loCell, wsv.Cells(n3 + 1, n1).Value, lcWhat, wsv.Cells(n3 + 1, n2).Value)
            Next n3
            Call ReplaceMask(c, wsv.Cells(n3 + 1, n1).Value, lcWhat, wsv.Cells(n3 + 1, n2).Value)
            
            GoTo ExitV
ErrV:
            n1 = MsgBox("Ошибка загрузки данных!", vbCritical + vbOKOnly, "Ошибка")
            Er = -1
ExitV:
            Application.DisplayAlerts = False
            wsv.Delete
        End If
    Loop Until c Is Nothing
    Set c = Nothing
    Set wsv = Nothing
    Set loCell = Nothing
    Set qt = Nothing
End Sub


Sub DubleColumns(curRange As Range)
Dim c As Range
    Do
        Set c = curRange.Find("#(", LookIn:=xlValues, LookAt:=xlPart)
        If Not c Is Nothing Then
            Call DubleMaskFields(c)
        End If
    Loop Until c Is Nothing
    Set c = Nothing
End Sub

Sub DubleRows(curRange As Range)
Dim c As Range
    Do
        Set c = curRange.Find("##(", LookIn:=xlValues, LookAt:=xlPart)
        If Not c Is Nothing Then
            Call DubleRowMaskFields(c)
        End If
    Loop Until c Is Nothing
    Set c = Nothing
End Sub

Sub RedefineFields(curRange As Range)
Dim i As Long, j As Integer, c As Range, fName As String, frange As String, fval As String, fnrange As String, _
        frange2 As String, frange3 As String, Com As Comment, cCom As String
'    Application.StatusBar = "Преобразование полей..."
    For i = 1 To columnsCount
        fName = wsd.Cells(DataStartRow - 1, i).Value   ' Имя поля
                                                                       
On Error Resume Next
        
        wsd.Parent.Names.Add Name:=fName, RefersToR1C1:="=Данные!R" + Trim(Str(DataStartRow - 3)) + "C" + Trim(Str(0 + i))

On Error GoTo 0

        wsd.Cells(DataStartRow - 3, 0 + i).Value = "-1"

        wsd.Parent.Names.Add Name:="IsUp_" + fName, RefersToR1C1:="=Данные!R" + Trim(Str(DataStartRow - 5)) + "C" + Trim(Str(0 + i))
        wsd.Cells(DataStartRow - 5, 0 + i).Value = False

        fval = "ДВССЫЛ(""Данные!R"" & CurRow & ""C" & i & """;ЛОЖЬ)"
        fnrange = "ДВССЫЛ(""Данные!R"" & StartData & ""C" & i & ":R"" & CurRow & ""C" & i & """;ЛОЖЬ)"
        frange2 = "ДВССЫЛ(""Данные!R"" & StartRow & ""C" & i & ":R"" & CurRow & ""C" & i & """;ЛОЖЬ)"
        frange3 = "ДВССЫЛ(""Данные!R"" & StartData & ""C" & i & ":R"" & CurRow-1 & ""C" & i & """;ЛОЖЬ)"
        curRange.Replace What:="{" + fName + "}", Replacement:=fval, LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False ' Замена

'исправлено 07.07.2004
        For j = 1 To groupCount
            frange = "ДВССЫЛ(""Данные!R"" & Start" + Trim(Str(j)) + " & ""C" & i & ":R"" & End" + Trim(Str(j)) + " & ""C" & i & """;ЛОЖЬ)"
            curRange.Replace What:="<" + fName + ">(" + Trim(Str(j)) + ")", Replacement:=frange, LookAt:=xlPart, _
                SearchOrder:=xlByRows, MatchCase:=False ' Замена
        Next j

'добавлено 07.07.2004
        frange = "ДВССЫЛ(""Данные!R"" & StartPred & ""C" & i & ":R"" & EndPred & ""C" & i & """;ЛОЖЬ)"
        curRange.Replace What:="<" + fName + ">(Prev)", Replacement:=frange, LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False ' Замена

        frange = "ДВССЫЛ(""Данные!R"" & StartRow & ""C" & i & ":R"" & EndRow & ""C" & i & """;ЛОЖЬ)"
        curRange.Replace What:="<" + fName + ">", Replacement:=frange, LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False ' Замена
        curRange.Replace What:="/" + fName + "/", Replacement:=frange2, LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False ' Замена
        curRange.Replace What:="\" + fName + "\", Replacement:=frange3, LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False ' Замена

'Добавлено 07.03.2005
        If wso.Comments.Count > 0 Then
            For Each Com In wso.Comments
                cCom = Com.Text
                cCom = StrReplace(StrReplace(StrReplace(cCom, "{" + fName + "}", fval), ">>", "="), "<" + fName + ">", frange)
                Com.Text Text:=cCom
            Next Com
        End If


'исправлено 07.07.2004
        For j = 1 To groupCount
            frange = "ДВССЫЛ(""Данные!R"" & Start" + Trim(Str(j)) + " & ""C" & i & ":R"" & CurRow & ""C" & i & """;ЛОЖЬ)"
            curRange.Replace What:="[" + fName + "](" + Trim(Str(j)) + ")", Replacement:=frange, LookAt:=xlPart, _
                SearchOrder:=xlByRows, MatchCase:=False ' Замена
        Next j
        curRange.Replace What:="[" + fName + "]", Replacement:=fnrange, LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False ' Замена
    Next i
' Вычисление формул, начинающихся на ">>"
    Set c = curRange.Find(">>", LookIn:=xlValues, LookAt:=xlPart)
    If Not c Is Nothing Then
        Do
            If Mid(c.Value, 3, 1) <> ">" Then
                If Mid(c.Value, 3, 1) <> "=" Then
                    On Error GoTo ErrAddr
                    c.FormulaLocal = "=" + Mid(c.Value, 3)
                    GoTo NotErrAddr
ErrAddr:            MsgBox ("Ошибка в формуле по адресу: " & c.Address(False, False))
                    c.Value = Mid(c.Value, 3)
NotErrAddr:         On Error GoTo 0
                Else
                    c.Value = "<==>" + Mid(c.Value, 4)
                End If
            Else
                c.Value = "<=>" + Mid(c.Value, 4)
            End If
            Set c = curRange.FindNext(c)
        Loop While Not c Is Nothing
    End If
    Set c = Nothing
End Sub

Sub f1()
Dim i As Long, c As Range, lB As Boolean
'    Application.StatusBar = "Подготовка к формированию отчета..."
    wsd.Select
    curPosD = DataStartRow
    gStartPosD(0) = DataStartRow
    groupCount = wso.[B1].Value
    gEndPosH(0) = 0       ' Конечная строка шапки группы

    If SheetFieldName <> "" Then
        groupCount = groupCount + 1
    End If

    For i = 1 To groupCount
        If SheetFieldName <> "" And i = 1 Then
            gStartPosH(i) = 1 ' Начальная строка шапки группы
            gEndPosH(i) = 0
            groupProp(i, 0) = SheetFieldName
            Set c = wsd.Range(Cells(DataStartRow - 1, 1), Cells(DataStartRow - 1, columnsCount)).Find(groupProp(i, 0), LookIn:=xlValues, LookAt:=xlWhole)
            If Not c Is Nothing Then
                groupProp(i, 1) = c.Column
            Else
                groupProp(i, 1) = 0
            End If
            groupProp(i, 14) = SheetFieldName
            groupProp(i, 2) = True
            groupProp(i, 3) = True
            groupProp(i, 4) = False
            groupProp(i, 5) = False
            groupProp(i, 6) = False
            groupProp(i, 7) = True  'Группа начинается на новом листе
            groupProp(i, 8) = True  'Группа начинается на новой странице
            groupProp(i, 9) = ""   'Дополнительная команда
            groupProp(i, 10) = 0    ' Строка начала группы в выходном отчете
            groupProp(i, 11) = 0    ' Номер группы
            groupProp(i, 12) = "" ' Условие вывода
        Else
            gStartPosH(i) = gEndPosH(i - 1) + 2 ' Начальная строка шапки группы
            gEndPosH(i) = gEndPosH(i - 1) + 1
            Do While Not (wso.Cells(gEndPosH(i) + 1, 1).Value Like "^ Шапка*")
                gEndPosH(i) = gEndPosH(i) + 1
            Loop
            groupProp(i, 0) = wso.Cells(gEndPosH(i) + 1, 2).Value
            Set c = wsd.Range(Cells(DataStartRow - 1, 1), Cells(DataStartRow - 1, columnsCount)).Find(groupProp(i, 0), LookIn:=xlValues, LookAt:=xlWhole)
            If Not c Is Nothing Then
                groupProp(i, 1) = c.Column
            Else
                groupProp(i, 1) = 0
            End If
            groupProp(i, 14) = wso.Cells(gEndPosH(i) + 1, 2).Value
            groupProp(i, 2) = wso.Cells(gEndPosH(i) + 1, 3).Value
            groupProp(i, 3) = wso.Cells(gEndPosH(i) + 1, 4).Value
            groupProp(i, 4) = wso.Cells(gEndPosH(i) + 1, 5).Value
            groupProp(i, 5) = wso.Cells(gEndPosH(i) + 1, 6).Value
            lB = wso.Cells(gEndPosH(i) + 1, 7).Value
            groupProp(i, 6) = lB
            groupProp(i, 7) = True  'Группа начинается на новом листе
            groupProp(i, 8) = True  'Группа начинается на новой странице
            groupProp(i, 9) = wso.Cells(gEndPosH(i) + 1, 9).Value   'Дополнительная команда
            groupProp(i, 10) = 0    ' Строка начала группы в выходном отчете
            groupProp(i, 11) = 0    ' Номер группы
            groupProp(i, 12) = wso.Cells(gEndPosH(i) + 1, 8).Value ' Условие вывода
        End If
        
    Next i
    gStartPosDet = gEndPosH(groupCount) + 2 ' Начальная строка Detail
    gEndPosDet = gEndPosH(groupCount) + 1   ' Конечная строка Detail
    Do While Not (wso.Cells(gEndPosDet + 1, 1).Value Like "^ Данные*")
        gEndPosDet = gEndPosDet + 1
    Loop
    HideDetail = (wso.Cells(gEndPosDet + 1, 2) <> "")
    groupProp(0, 12) = wso.Cells(gEndPosDet + 1, 8).Value ' Условие вывода
    gEndPosF(groupCount + 1) = gEndPosDet          ' Конечная строка концовки группы
    For i = groupCount To 1 Step -1
    
        If SheetFieldName <> "" And i = 1 Then
            gStartPosF(i) = gEndPosF(i + 1) + 1
            gEndPosF(i) = gEndPosF(i + 1)
        Else
            gStartPosF(i) = gEndPosF(i + 1) + 2 ' Начальная строка концовки группы
            gEndPosF(i) = gEndPosF(i + 1) + 1
            Do While Not (wso.Cells(gEndPosF(i) + 1, 1).Value Like "^ Концовка*")
                gEndPosF(i) = gEndPosF(i) + 1
            Loop
            groupProp(i, 13) = wso.Cells(gEndPosF(i) + 1, 8).Value ' Условие вывода
        End If
                
        gFPosR(i) = ""
        gbFPosR(i) = False
        If gEndPosF(i) >= gStartPosF(i) Then
            Set c = wso.Range(Trim(Str(gStartPosF(i))) + ":" + Trim(Str(gEndPosF(i)))).Find("СУММПРЕДКОНЦ", LookIn:=xlValues, LookAt:=xlPart)
            If Not c Is Nothing Then gbFPosR(i) = True
        End If
        
    Next i
    gEndPosD(0) = rowsCount + DataStartRow - 1
    Set c = Nothing
End Sub

Sub f1_2()
    Dim i As Long
    wso.Cells(gEndPosDet + 1, 8).Value = groupProp(0, 12)
    For i = 1 To groupCount
        wso.Cells(gEndPosH(i) + 1, 8).Value = groupProp(i, 12)
        wso.Cells(gEndPosF(i) + 1, 8).Value = groupProp(i, 13)
    Next i
End Sub


Sub f2(ByVal curGr As Integer)      ' curGr - Текущая группа
Dim startPosGr As Long, endPosGr As Long, c As Range, b As Boolean, i As Long, bNotPrint As Boolean, _
    oSheet As Object, cSheetName As String, bNew As Boolean, lcFormula As String
    Do

        gFPosR(curGr + 1) = ""
        groupProp(curGr, 11) = groupProp(curGr, 11) + 1
        rGroupOrderRange = curGr
        rCurentRange = groupProp(curGr, 11)
        gStartPosD(curGr) = curPosD ' Начальная строка данных
        rStartGroup.Offset(0, curGr - 1).Value = curPosD

        If groupProp(curGr, 1) > 0 Then ' Если столбец группировки не 0 (не отчет)
            gVal(curGr) = wsd.Cells(curPosD, groupProp(curGr, 1)).Value ' Значение столбца группы
            
            ' добавлено 16/08/2006
            wsd.Parent.Names("IsUp_" + groupProp(curGr, 0)).RefersToRange.Value = True
 
            wsd.Parent.Names(groupProp(curGr, 14)).RefersToRange.NumberFormat = "@"
            wsd.Parent.Names(groupProp(curGr, 14)).RefersToRange.Value = gVal(curGr)

            gEndPosD(curGr) = curPosD   ' Конечная строка данных
            Do While (gEndPosD(curGr) <> gEndPosD(curGr - 1)) And _
                (wsd.Cells(gEndPosD(curGr) + 1, groupProp(curGr, 1)).Value = gVal(curGr))
                gEndPosD(curGr) = gEndPosD(curGr) + 1
            Loop
        Else
            gEndPosD(curGr) = gEndPosD(curGr - 1)
        End If

        rEndGroup.Offset(0, curGr - 1).Value = gEndPosD(curGr)

'добавлено 07.07.2004
        rStartPredGroup.Value = IIf(nStartPredGroup > 0, nStartPredGroup, curPosD)
        rEndPredGroup.Value = IIf(nEndPredGroup > 0, nEndPredGroup, gEndPosD(curGr))
        nStartPredGroup = curPosD
        nEndPredGroup = gEndPosD(curGr)
        rPredGroupValue.Value = IIf(cPredGroupValue <> "#####", cPredGroupValue, gVal(curGr))
        cPredGroupValue = gVal(curGr)


        rPredGroupName.Value = IIf(curGr > 1, groupProp(curGr - 1, 0), "")

                    
        ' Создание нового листа
        If (groupProp(curGr, 2) And Not nxlPages) Or curPosR > 35000 Then
            If groupProp(curGr, 7) Then
                groupProp(curGr, 7) = False
            Else
                cSheetName = ""
                If SheetFieldName <> "" Then
                    wsd.Activate
                    Set c = wsd.Range(Cells(DataStartRow - 1, 1), Cells(DataStartRow - 1, columnsCount)).Find(SheetFieldName, LookIn:=xlValues, LookAt:=xlWhole)
                    If Not c Is Nothing Then
                        cSheetName = wsd.Cells(curPosD, c.Column)

'Изменение формирования имен листов для пакетной выгрузки
                        If cSheetName Like "[#]*[#]*[#]*" Then
                            SheetsNames(wsr.Index + 1) = cSheetName
                            cSheetName = ""
                        End If
                    End If
                    wsr.Activate
                End If
                bNew = True
                If cSheetName <> "" Then
                    For Each oSheet In Sheets
                        If oSheet.Name = cSheetName Then
                            bNew = False
                            Set wsr = oSheet
                            curPosR = LastCell(wsr.Cells).Row + 2
                            groupProp(curGr, 8) = True
                            For i = curGr + 1 To groupCount
                                groupProp(i, 7) = True
                            Next i
                            wsr.Activate
                        End If
                    Next oSheet
                End If
                If bNew Then

'добавлено 19.07.2005
                    bCalcFooter = True

                    Sheets(lcWsoName).Copy Before:=wsd
                    Set wsr = Application.ActiveSheet
                    wsr.Rows("1:10000").Delete Shift:=xlUp
'Удаление ненужных картинок
                    For i = wsr.Shapes.Count To 1 Step -1
                        wsr.Shapes(i).Delete
                    Next i

                    If cSheetName <> "" Then wsr.Name = Left(cSheetName, 31)
                    Application.DisplayAlerts = False
                    On Error GoTo ErrP2
                    With ActiveSheet.PageSetup
                       If lbBlackAndWhite Then
                          .BlackAndWhite = True
                       End If
                       .LeftHeader = "&8" & nxlLeftHeader
                       .CenterHeader = "&8" & nxlCenterHeader
                       .RightHeader = "&8" & nxlRightHeader
                    End With
ErrP2:              On Error GoTo 0
                    curPosR = 1
                    groupProp(curGr, 8) = True
                    For i = curGr + 1 To groupCount
                        groupProp(i, 7) = True
                    Next i
                End If
            End If
        End If
        If groupProp(curGr, 3) Then 'And Not nxlPages Then
            If groupProp(curGr, 8) And groupProp(curGr, 9) <> "BR" Then
                groupProp(curGr, 8) = False
            Else
                On Error Resume Next
                wsr.HPageBreaks.Add Before:=wsr.Cells(curPosR, 1)
                For i = curGr + 1 To groupCount
                    groupProp(i, 8) = True
                Next i
                On Error GoTo 0
            End If
        End If
        groupProp(curGr, 10) = curPosR
        ' Копирование шапки группы

        rCurRow.Value = gStartPosD(curGr)
        rStartRow.Value = gStartPosD(curGr)
        rEndRow.Value = gEndPosD(curGr)

        With wso.Cells(gEndPosH(curGr) + 1, 8)
            On Error Resume Next
            lcFormula = .FormulaLocal
            .FormulaLocal = lcFormula
            .Calculate
            If .Value <> "" Then
                bNotPrint = .Value
            Else
                bNotPrint = True
            End If
            On Error GoTo 0
        End With

'добавлено 19.07.2005
        If bCalcFooter Then
            On Error GoTo PErr2
            If LFooter <> "" Then
                wso.Cells(gEndPosF(curGr) + 1, 10).FormulaLocal = LFooter
                wsr.PageSetup.LeftFooter = wso.Cells(gEndPosF(curGr) + 1, 10).Value
            End If
            If CFooter <> "" Then
                wso.Cells(gEndPosF(curGr) + 1, 11).FormulaLocal = CFooter
                wsr.PageSetup.CenterFooter = wso.Cells(gEndPosF(curGr) + 1, 11).Value
            End If
            If RFooter <> "" Then
                wso.Cells(gEndPosF(curGr) + 1, 12).FormulaLocal = RFooter
                wsr.PageSetup.RightFooter = wso.Cells(gEndPosF(curGr) + 1, 12).Value
            End If
PErr2:      On Error GoTo 0
            bCalcFooter = False
        End If

'        wso.Cells(gEndPosH(curGr) + 1, 8).Calculate
'        If wso.Cells(gEndPosH(curGr) + 1, 8) <> "" Then
'            bNotPrint = wso.Cells(gEndPosH(curGr) + 1, 8)
'        Else
'            bNotPrint = True
'        End If


        If ((gEndPosH(curGr) - gStartPosH(curGr) + 1) > 0) And bNotPrint Then
            ' добавлено 07.03.2005
            lnComCount = wsr.Comments.Count
            
            wso.Rows(Trim(Str(gStartPosH(curGr))) + ":" + Trim(Str(gEndPosH(curGr)))).Copy _
                Destination:=wsr.Rows(curPosR)
            ' Вычисление данных
            '!!!!!!!!!!!!!!!!!!!!!!


            Call f3(curPosR, curPosR + gEndPosH(curGr) - gStartPosH(curGr), _
                    gStartPosD(curGr), gEndPosD(curGr), _
                    gStartPosD(curGr))
            '!!!!!!!!!!!!!!!!!!!!!!


            On Error Resume Next
            If groupProp(curGr, 5) Then
                wsr.PageSetup.PrintTitleRows = _
                "$" + Trim(Str(curPosR)) + ":$" + Trim(Str(curPosR + gEndPosH(curGr) - gStartPosH(curGr)))
            End If
            On Error GoTo 0
            curPosR = curPosR + gEndPosH(curGr) - gStartPosH(curGr) + 1
            If groupProp(curGr, 6) And Not nxlFreezePanes Then
                wsr.Activate
                wsr.Rows(Trim(Str(curPosR)) + ":" + Trim(Str(curPosR))).Select
                ActiveWindow.FreezePanes = True
            End If
        End If
        startPosGr = curPosR

        If curGr = groupCount Then
            Do
                ' Копирование Detail

                rCurRow.Value = curPosD

                With wso.Cells(gEndPosDet + 1, 8)
                   On Error Resume Next
                   lcFormula = .FormulaLocal
                   .FormulaLocal = lcFormula
                   .Calculate
                   If .Value <> "" Then
                       bNotPrint = .Value
                   Else
                       bNotPrint = True
                   End If
                   On Error GoTo 0
                End With

'                wso.Cells(gEndPosDet + 1, 8).Calculate
'                If wso.Cells(gEndPosDet + 1, 8) <> "" Then
'                    bNotPrint = wso.Cells(gEndPosDet + 1, 8)
'                Else
'                    bNotPrint = True
'                End If

                Application.StatusBar = "Формирование документа (" _
                + Trim(Str(Int((curPosD - DataStartRow + 1) / rowsCount * 100))) + "%)"

                b = False
                If HideDetail Then
                    Set c = wsd.Range("DataFields").Find(wso.Cells(gEndPosDet + 1, 2), LookIn:=xlValues, LookAt:=xlWhole)
                    If Not c Is Nothing Then
                        b = wsd.Cells(curPosD, c.Column).Value
                     End If
                End If

                If ((gEndPosDet - gStartPosDet + 1) > 0) And (Not b) And bNotPrint Then
                    wso.Rows(Trim(Str(gStartPosDet)) + ":" + Trim(Str(gEndPosDet))).Copy
                    wsr.Paste Destination:=wsr.Rows(curPosR)
                    ' Вычисление данных
                    '!!!!!!!!!!!!!!!!!!!!!!
                    Call f3(curPosR, curPosR + gEndPosDet - gStartPosDet, _
                            gStartPosD(curGr), gEndPosD(curGr), _
                            curPosD)
                    '!!!!!!!!!!!!!!!!!!!!!!
                    curPosR = curPosR + gEndPosDet - gStartPosDet + 1
                    wsr.Cells(curPosR + 3, 1).Select
                End If
                curPosD = curPosD + 1
            Loop Until curPosD > gEndPosD(curGr)
        Else
            ' Рекурсивный вызов !!!!!!!!!!!!!
            groupProp(curGr + 1, 11) = 0
            Call f2(curGr + 1)
        End If
        endPosGr = curPosR
        If groupProp(curGr, 4) Then
            On Error Resume Next
            wsr.Rows(Trim(Str(startPosGr)) + ":" + Trim(Str(endPosGr))).Group
            On Error GoTo 0
        End If
        ' Копирование концовки группы

        rCurRow.Value = gEndPosD(curGr)
        rStartRow.Value = gStartPosD(curGr)
        rEndRow.Value = gEndPosD(curGr)

        With wso.Cells(gEndPosF(curGr) + 1, 8)
            On Error Resume Next
            lcFormula = .FormulaLocal
            .FormulaLocal = lcFormula
            .Calculate
            If .Value <> "" Then
                bNotPrint = .Value
            Else
                bNotPrint = True
            End If
            On Error GoTo 0
        End With

'        wso.Cells(gEndPosF(curGr) + 1, 8).Calculate
'        If wso.Cells(gEndPosF(curGr) + 1, 8) <> "" Then
'            bNotPrint = wso.Cells(gEndPosF(curGr) + 1, 8)
'        Else
'            bNotPrint = True
'        End If

        If ((gEndPosF(curGr) - gStartPosF(curGr) + 1) > 0) And bNotPrint Then
            
            wso.Rows(Trim(Str(gStartPosF(curGr))) + ":" + Trim(Str(gEndPosF(curGr)))).Copy _
                Destination:=wsr.Rows(curPosR)
            
            
            If gbFPosR(curGr - 1) And curGr > 1 Then
                gFPosR(curGr) = gFPosR(curGr) & "+" & curPosR
            End If
            If gbFPosR(curGr) Then
                Do
                    Set c = wsr.Rows(Trim(Str(curPosR)) + ":" + Trim(Str(curPosR + gEndPosF(curGr) - gStartPosF(curGr)))).Find("СУММПРЕДКОНЦ", LookIn:=xlValues, LookAt:=xlPart)
                    If Not c Is Nothing Then
                        c.Value = StrReplace(c.Value, "СУММПРЕДКОНЦ", Mid(StrReplace(gFPosR(curGr + 1), "+", "+" & Mid(c.Address(True, False), 1, InStr(1, c.Address(True, False), "$") - 1)), 2))
                    End If
                Loop Until c Is Nothing
            End If
            
            
            ' Вычисление данных
            '!!!!!!!!!!!!!!!!!!!!!!
            Call f3(curPosR, curPosR + gEndPosF(curGr) - gStartPosF(curGr), _
                    gStartPosD(curGr), gEndPosD(curGr), _
                    gEndPosD(curGr))
            '!!!!!!!!!!!!!!!!!!!!!!
            curPosR = curPosR + gEndPosF(curGr) - gStartPosF(curGr) + 1
            wsr.Activate
            wsr.Cells(curPosR + 3, 1).Select
        End If
        If Mid(groupProp(curGr, 9), 1, 9) = "TRANSPOSE" Then
            wsr.Range(Cells(groupProp(curGr, 10), 1), Cells(curPosR - 1, Val(Mid(groupProp(curGr, 9), 10)))).Copy
            wsr.Cells(curPosR, 1).PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
            Application.CutCopyMode = False
            wsr.Rows(Trim(Str(groupProp(curGr, 10))) + ":" + Trim(Str(curPosR - 1))).Delete Shift:=xlUp
            curPosR = groupProp(curGr, 10) + Val(Mid(groupProp(curGr, 9), 10))
        End If
        If groupProp(curGr, 1) > 0 Then ' Если столбец группировки не 0 (не отчет)
            wsd.Parent.Names(groupProp(curGr, 14)).RefersToRange.NumberFormat = "@"
            wsd.Parent.Names(groupProp(curGr, 14)).RefersToRange.Value = ""
        
            ' добавлено 16/08/2006
            wsd.Parent.Names("IsUp_" + groupProp(curGr, 0)).RefersToRange.Value = False
        End If
    Loop Until (gEndPosD(curGr) = gEndPosD(curGr - 1))
    Set c = Nothing
End Sub

Sub f3(startPosRepl, endPosRepl, _
        startPosD, endPosD, _
        curPosData)
Dim c As Range, curRange As Range, lbText As Boolean, cText As String, _
    lcFormula As String, lbMerge As Boolean, i As Long

    Set curRange = wsr.Rows(Trim(Str(startPosRepl)) + ":" + Trim(Str(endPosRepl))) ' Диапазон
    rCurRow.Value = curPosData
    rStartRow.Value = startPosD
    rEndRow.Value = endPosD
    On Error GoTo m1

    ' Вычисление формул, начинающихся на "<==>"
    Set c = curRange.Find("<==>", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows)
    If Not c Is Nothing Then
        Do
            c.Value = "Eval" + Mid(c.Value, 5)

            ' Добавлено 10.03.2005 Иванов С.В.
            ' Проверка на существущий комментарий для формул
            If c.Comment Is Nothing Then
                c.AddComment ("Eval")
            End If
            ' 10.03.2005

            Set c = curRange.Find("<==>", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows)
        Loop While Not c Is Nothing
    End If
    ' Вычисление формул, начинающихся на "<=>"
    Set c = curRange.Find("<=>", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows)
    If Not c Is Nothing Then
        Do
            c.FormulaLocal = "=" + Mid(c.Value, 4)
            If Not c Is Nothing Then
                lbMerge = c.MergeCells
                c.AddComment ("Fit")
                c.WrapText = True
                If lbMerge Then c.MergeArea.MergeCells = True
            End If
            Set c = curRange.Find("<=>", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows)
        Loop While Not c Is Nothing
    End If
    If Not curRange.Find("=*", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows) Is Nothing Then
       ' Замена формул на значения
        For Each c In curRange.SpecialCells(xlCellTypeFormulas)
            With c
                lcFormula = .FormulaLocal
                lcFormula = StrReplace(lcFormula, """ & CurRow & """, RTrim(LTrim(curPosData)))
                lcFormula = StrReplace(lcFormula, """ & StartRow & """, RTrim(LTrim(startPosD)))
                lcFormula = StrReplace(lcFormula, """ & EndRow & """, RTrim(LTrim(endPosD)))
                lcFormula = StrReplace(lcFormula, """ & CurRow-1 & """, RTrim(LTrim(curPosData - 1)))
                lcFormula = StrReplace(lcFormula, """ & StartData & """, RTrim(LTrim(DataStartRow)))
                lcFormula = StrReplace(lcFormula, "CurRow", RTrim(LTrim(curPosData)))
                lcFormula = StrReplace(lcFormula, "StartRow", RTrim(LTrim(startPosD)))
                lcFormula = StrReplace(lcFormula, "EndRow", RTrim(LTrim(endPosD)))
                lcFormula = StrReplace(lcFormula, "StartData", RTrim(LTrim(DataStartRow)))
                .FormulaLocal = lcFormula
    
                lbText = False
                If .NumberFormat = "0" Then
                    .NumberFormat = "General"
                    lbText = True
                End If
'                .Calculate
                If lbText Then
                    .NumberFormat = "@"
                End If
                If lbText And (.Text = "0") Then
                    cText = ""
                Else
                    cText = .Text
                    If Len(cText) = 1024 Then
                        cText = .Value
                    End If
                End If
                .FormulaLocal = IIf(Mid(cText, 1, 1) = "=", " ", "") + cText
                .Calculate
            End With
        Next c
    End If
    ' добавлено 07.03.2005
    For i = lnComCount + 1 To wsr.Comments.Count
        lcFormula = wsr.Comments(i).Text
        If lcFormula <> "Fit" And lcFormula <> "Eval" Then

            ' Добавлено 10.03.2005 Иванов С.В.
            ' простановка формул с комментраниями
            With wsr.Comments(i).Parent
                If Left(.Text, 4) = "Eval" And lcFormula <> "" Then
                    .FormulaLocal = "=" + Mid(.Text, 5)
                    .Calculate
                End If
            End With
            ' 10.03.2005

            With wsd.Cells(DataStartRow - 4, 1)
                .NumberFormat = "General"
                .FormulaLocal = lcFormula
                .Calculate
                cText = .Value
            End With
            wsr.Comments(i).Text Text:=cText
        End If
    Next i
m1:
    Set c = Nothing
    Set curRange = Nothing
End Sub

Sub Duble(loCellS As Range)         ' Процедура дублирует столбец (столбцы) данной ячейки
Dim loCellD As Range, i As Long  ' Ячейки исходного и сдублированного столбца,
Dim aWidth(255), oCell As Range     '   которые располагаются выше данной,
    loCellS.Select                  '   объединяются
    i = 0
    For Each oCell In Selection
        aWidth(i) = oCell.ColumnWidth
        i = i + 1
    Next oCell
    Selection.EntireColumn.Insert
    i = 0
    For Each oCell In Selection
        oCell.ColumnWidth = aWidth(i)
        i = i + 1
    Next oCell
    Set loCellD = Selection
    Range(loCellS, loCellS.Offset(LastCell(loCellS).Row, 0)).Select
    Selection.Copy Destination:=loCellD
    For i = 1 To loCellS.Row - 1
        Range(loCellD.Offset(-i, 0), loCellS.Offset(-i, 0)).MergeCells = Range(loCellD.Offset(-i, 0), loCellS.Offset(-i, 0)).Locked
    Next i
    Set loCellD = Nothing
    Set oCell = Nothing
End Sub

Sub ReplaceMask(loCellS As Range, lcValue As String, lcWhat As String, lcRepl As String)
Dim rRange As Range, c As Range, s1 As String, s2 As String
    loCellS.Select          ' Процедура заменяет значение ячейки на lcValue и
    loCellS.Value = lcValue ' ниже этой ячейки заменяет lcWhat на lcRepl
    Set rRange = Range(Selection, Selection.Offset(LastCell(Selection).Row, 0))
    rRange.Replace What:=lcWhat, Replacement:=lcRepl
    For Each c In rRange
        If Not (c.Comment Is Nothing) Then
            s1 = c.Comment.Text
            s2 = StrReplace(s1, lcWhat, lcRepl)
            If s2 <> s1 Then c.Comment.Text (s2)
        End If
    Next c
End Sub

Sub DubleMaskFields(loCellS As Range)
Dim loCell As Range, _
    lcMask As String, lcWhat As String, i As Long, j As Integer, _
    lnField As Integer, lnStar As Integer, lnSkobka As Integer, _
    laRepl(255, 2) As String, llNastr As Boolean  'Титов
    wso.Select
    lnStar = InStr(1, loCellS.Value, "#")
    lnSkobka = InStr(lnStar + 2, loCellS.Value, ")")
    lnField = lnStar
' Титов
        llNastr = False
    Do While (Mid(loCellS.Value, lnField - 1, 1) <> "{") And (Mid(loCellS.Value, lnField - 1, 1) <> "<")
' Титов
                If Mid(loCellS.Value, lnField - 1, 1) = ">" Then
                        llNastr = True
                        Exit Do
                End If
        lnField = lnField - 1
    Loop
    lcWhat = Mid(loCellS.Value, lnStar + 2, lnSkobka - lnStar - 2)
    lcMask = UCase(Mid(loCellS.Value, lnField, lnStar - lnField))
    i = 0
' Титов
        If llNastr Then
                For Each loCell In wsd.Range("NastrFields")
                If UCase(Mid(loCell, 1, lnStar - lnField)) = lcMask Then
                    i = i + 1
                    laRepl(i, 2) = Mid(loCell, lnStar - lnField + 1)
                    laRepl(i, 1) = Mid(loCellS.Value, 1, lnStar - 1) + laRepl(i, 2) + Mid(loCellS.Value, lnSkobka + 1)
                End If
            Next loCell
        Else
            For Each loCell In wsd.Range("DataFields")
                If UCase(Mid(loCell, 1, lnStar - lnField)) = lcMask Then
                    i = i + 1
                    laRepl(i, 2) = Mid(loCell, lnStar - lnField + 1)
                    laRepl(i, 1) = Mid(loCellS.Value, 1, lnStar - 1) + laRepl(i, 2) + Mid(loCellS.Value, lnSkobka + 1)
                        End If
            Next loCell
        End If
    For j = 1 To i - 1
        Call Duble(loCellS)
        loCellS.Offset(0, -1).Select
        Set loCell = Selection.Cells(1, 1)
        Call ReplaceMask(loCell, laRepl(j, 1), lcWhat, laRepl(j, 2))
    Next j
    Call ReplaceMask(loCellS, laRepl(i, 1), lcWhat, laRepl(i, 2))
    Set loCell = Nothing
End Sub

Sub DubleRowMaskFields(loCellS As Range)
Dim loCell As Range, _
    lcMask As String, lcWhat As String, i As Long, j As Integer, _
    lnField As Integer, lnStar As Integer, lnSkobka As Integer, _
    laRepl(255, 2) As String
    wso.Select
    lnStar = InStr(1, loCellS.Value, "#")
    lnSkobka = InStr(lnStar + 2, loCellS.Value, ")")
    lnField = lnStar
    Do While (Mid(loCellS.Value, lnField - 1, 1) <> "{") And (Mid(loCellS.Value, lnField - 1, 1) <> "<")
        lnField = lnField - 1
    Loop
    lcWhat = Mid(loCellS.Value, lnStar + 3, lnSkobka - lnStar - 3)
    lcMask = UCase(Mid(loCellS.Value, lnField, lnStar - lnField))
    i = 0
    For Each loCell In wsd.Range("DataFields")
        If UCase(Mid(loCell, 1, lnStar - lnField)) = lcMask Then
            i = i + 1
            laRepl(i, 2) = Mid(loCell, lnStar - lnField + 1)
            laRepl(i, 1) = Mid(loCellS.Value, 1, lnStar - 1) + laRepl(i, 2) + Mid(loCellS.Value, lnSkobka + 1)
        End If
    Next loCell
    For j = 1 To i - 1
        Call DubleRow(loCellS)
        loCellS.Offset(-1, 0).Select
        Set loCell = Selection.Cells(1, 1)
        Call ReplaceRowMask(loCell, laRepl(j, 1), lcWhat, laRepl(j, 2))
    Next j
    Call ReplaceRowMask(loCellS, laRepl(i, 1), lcWhat, laRepl(i, 2))
    Set loCell = Nothing
End Sub

Sub DubleRow(loCellS As Range)         ' Процедура дублирует строку (строки) данной ячейки
Dim loCellD As Range, i As Long
    loCellS.Select
    Selection.EntireRow.Insert
    Set loCellD = Selection.Cells(1, 1)
    Range(loCellS, loCellS.Offset(0, LastCell(loCellS).Column)).Select
    Selection.Copy Destination:=loCellD
    Set loCellD = Nothing
End Sub

Sub ReplaceRowMask(loCellS As Range, lcValue As String, lcWhat As String, lcRepl As String)
    loCellS.Select          ' Процедура заменяет значение ячейки на lcValue и
    loCellS.Value = lcValue ' правее этой ячейки заменяет lcWhat на lcRepl
    Range(Selection, Selection.Offset(0, LastCell(Selection).Column)).Replace What:=lcWhat, Replacement:=lcRepl
    Set loCellS = Nothing
End Sub

Sub AutoFitRow(rRange As Range)
Dim nWidth As Double, nHeight As Double, F As Font, rwRange As Range, i As Integer, nr As Integer, nw As Double
    Set rRange = rRange.MergeArea
    nWidth = rRange.Columns.Width
    nHeight = rRange.Rows.RowHeight
    nr = rRange.Rows.Count
    If nr = 1 Then
        nHeight = rRange.Rows.RowHeight
    Else
        nHeight = 0
        For i = 1 To nr
            nHeight = nHeight + rRange(i, 1).Rows.RowHeight
        Next i
    End If
    Set rwRange = wsd.Cells(rowsCount + 100, 1)
    nw = Round((nWidth - 3.72) / 5.25 - 0.05, 1)
    rwRange.ColumnWidth = IIf(nw > 255, 255, nw)
    rwRange.HorizontalAlignment = rRange.HorizontalAlignment
    rwRange.VerticalAlignment = rRange.VerticalAlignment
    rwRange.Value = rRange(1, 1).Value
    rwRange.WrapText = True
    Set F = rRange.Cells(1, 1).Font
    With rwRange.Font
        .Name = F.Name
        .FontStyle = F.FontStyle
        .Size = F.Size
        .Bold = F.Bold
        .Italic = F.Italic
    End With
    rwRange.Rows.AutoFit
    rRange.WrapText = True
    If nr = 1 Then
       nHeight = IIf(rwRange.Rows.RowHeight > nHeight, rwRange.Rows.RowHeight, nHeight)
       rRange.Rows.RowHeight = nHeight
    Else
        If rwRange.Rows.RowHeight > nHeight Then
            rRange(nr, 1).Rows.RowHeight = rRange(nr, 1).Rows.RowHeight + (rwRange.Rows.RowHeight - nHeight)
        End If
    End If
End Sub

Function LastCell(r As Range) As Range
Dim rLast As Range, rLast2 As Range, nCol As Integer, nRow As Long
    Set rLast = r.Cells.SpecialCells(xlLastCell)
    nCol = rLast.Column
    nRow = rLast.Row
    If rLast.Cells(1, 1).Value = "" Then
        On Error Resume Next
        Set rLast = r.Parent.Cells(r.Parent.Cells.Find("*", rLast, xlFormulas, , xlByRows, xlPrevious).Row, r.Parent.Cells.Find("*", rLast, xlFormulas, , xlByColumns, xlPrevious).Column)
        If Err.Number <> 0 Then
            Set rLast = r.Parent.Cells(1, 1)
        Else
            Set rLast = r.Parent.Cells(IIf(nRow > rLast.Row, nRow, rLast.Row), IIf(nCol > rLast.Column, nCol, rLast.Column))
        End If
        On Error GoTo 0
    End If
    Set LastCell = rLast
    Set rLast = Nothing
End Function

Sub LoadNastr(lrNastr As Range)
Dim i As Long, lnNastrRow As Integer, lnNastrCol As Integer, qt As QueryTable, _
    n As Integer, lcName As String, lcText As String 'Титов
    dbPath = IIf(dbPath = "", ThisWorkbook.Path + "\", dbPath)
    If Dir(dbPath + "c_nastr.dbf", vbNormal) <> "" Then
        lnNastrRow = lrNastr.Row
        lnNastrCol = lrNastr.Column
        
        lrNastr.Parent.Activate
        
        If LoadVFPData(lrNastr, dbPath, "SELECT * FROM C_NASTR.DBF", rowsCount) < 0 Then GoTo Err1
        
        lrNastr.Parent.Parent.Names.Add Name:="NastrFields", _
         RefersToR1C1:="=" + lrNastr.Parent.Name + "!R" + Trim(Str(lnNastrRow + 1)) + "C" + Trim(Str(lnNastrCol)) + ":R" + Trim(Str(lnNastrRow + rowsCount)) + "C" + Trim(Str(lnNastrCol))
        For i = 1 To rowsCount
            lcName = lrNastr.Parent.Cells(lnNastrRow + i, lnNastrCol)
            If lcName <> "" Then
                lrNastr.Parent.Parent.Names.Add Name:=lcName, _
                   RefersToR1C1:="=" + lrNastr.Parent.Name + "!R" + Trim(Str(lnNastrRow + i)) + "C" + Trim(Str(lnNastrCol + 1))
                If Mid(lcName, 1, 1) <> "c" Then
                    With lrNastr.Parent.Cells(lnNastrRow + i, lnNastrCol + 1)
                        If VarType(.Value) = vbString Then ' Титов
                            lcText = .Value
                        Else
                            lcText = .Text
                        End If
                        .FormulaLocal = IIf(Mid(lcText, 1, 1) = "=", " ", "") + lcText
                        '.FormulaLocal = IIf(Mid(.Text, 1, 1) = "=", " ", "") + .Text
                    End With
                End If
            End If
        Next i
        GoTo ExitProc
Err1:
        n = MsgBox("Ошибка загрузки данных!", vbCritical + vbOKOnly, "Ошибка")
        Er = -1
ExitProc:
    End If
    Set qt = Nothing
End Sub



Sub SetPageHeight()
Dim nZoom As Single, DX As Single, nPages As Integer
    If ActiveSheet.PageSetup.Zoom = False Then
        nPages = ActiveSheet.PageSetup.FitToPagesWide - 1
        If nPages > 0 Then
            ActiveSheet.PageSetup.Zoom = 100
'            ActiveSheet.PageSetup.PrintTitleColumns = ""
            If ActiveSheet.VPageBreaks.Count > nPages Then
                nZoom = 100
                DX = 100
                With ActiveSheet.PageSetup
                    While (DX > 0.5) And (nZoom > 10)
                        DX = DX / 2
                        If ActiveSheet.VPageBreaks.Count > nPages Then
                            nZoom = nZoom - DX
                        Else
                            nZoom = nZoom + DX
                        End If
                       .Zoom = Int(nZoom)
'                      .PrintTitleColumns = ""
                    Wend
                    If ActiveSheet.VPageBreaks.Count > nPages Then
                        .Zoom = .Zoom - 1
'                       .PrintTitleColumns = ""
                    End If
               End With
           End If
        End If
    End If
End Sub

Sub SetLastRowsCount(ByVal nLastRowsCount As Integer)
Dim nLastRow As Integer, nPageRow As Integer
    If nLastRowsCount > 0 Then
        nLastRow = LastCell(ActiveSheet.Cells).Row + 1
        ActiveWindow.ScrollRow = nLastRow
'        nPageRow = ActiveSheet.HPageBreaks.Count
'        If ActiveSheet.HPageBreaks.Count > 0 Then
'            nPageRow = ActiveSheet.HPageBreaks(ActiveSheet.HPageBreaks.Count).Location.Row
'            If (nLastRow - nPageRow) < nLastRowsCount Then
'                ActiveSheet.HPageBreaks.Add ActiveSheet.Cells(nLastRow - nLastRowsCount, 1)
'            End If
'        End If
    End If
End Sub

Sub HideColumn()
    Dim c As Range
    Set c = Cells.Find("#?/?", LookIn:=xlValues)
    If Not c Is Nothing Then
        Do
            c.Interior.Pattern = xlPatternGray50
            c.Value = ""
            c.Select
            Selection.EntireColumn.Hidden = True
            Set c = Cells.FindNext(c)
        Loop While Not c Is Nothing
    End If
    Set c = Nothing
End Sub

Function GetStrParam(lcParam As String, ByVal lnParam As Integer) As String
Dim nPos1 As Integer, nPos2 As Integer, i As Long
    nPos1 = 0
    i = 1
    While i < lnParam
        nPos1 = InStr(nPos1 + 1, lcParam, "#")
        If nPos1 = 0 Then
            GetStrParam = ""
            Exit Function
        End If
        i = i + 1
    Wend
    nPos2 = InStr(nPos1 + 1, lcParam, "#")
    nPos2 = IIf(nPos2 = 0, Len(lcParam), nPos2 - 1)
    If nPos2 > nPos1 Then
        GetStrParam = Mid(lcParam, nPos1 + 1, nPos2 - nPos1)
    Else
        GetStrParam = ""
    End If
End Function

Function StrReplace(ByVal cWhere As String, ByVal cWhat As String, ByVal cRepl As String) As String
Dim n As Integer
    n = 1
    Do
        n = InStr(n, cWhere, cWhat)
        If n > 0 Then
            cWhere = Mid(cWhere, 1, n - 1) + cRepl + Mid(cWhere, n + Len(cWhat))
            n = n + Len(cRepl)
        End If
    Loop While n <> 0
    StrReplace = cWhere
End Function

Function SaveSheet(filePath As String) As Integer
Dim ws As Object, fName As String, nRow As Integer
    Set ws = Application.ActiveWorkbook.ActiveSheet
    If ws.Visible <> xlSheetVeryHidden Then

'Изменение формирования имен листов для пакетной выгрузки
        fName = SheetsNames(ws.Index)

        If Not (fName Like "[#]*[#]*[#]*") Then
            fName = filePath + ws.Name
        Else
            fName = filePath + fName
        End If

        On Error GoTo 0
        On Error GoTo ss02
        Workbooks.Open fileName:=fName + ".xls"
        
        nRow = LastCell(Cells).Row
        If nRow >= 5000 Then
            ws.Copy Before:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
        Else
            ws.Range(ws.Cells(1, 1), LastCell(ws.Cells)).EntireRow.Copy
            nRow = LastCell(Cells).Row
            ActiveSheet.Cells(nRow + 1, 1).Insert Shift:=xlDown
        End If
        ActiveSheet.HPageBreaks.Add Before:=ActiveSheet.Cells(nRow + 1, 1)
        ActiveWorkbook.Close SaveChanges:=True

        GoTo ss01
ss02:   On Error GoTo 0
        ws.Copy
        ActiveWorkbook.SaveAs fileName:=fName + ".xls", FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
        ActiveWindow.Close
ss01:   On Error GoTo 0
    End If
    SaveSheet = 1
End Function

Function SaveBook(fileName As String) As Integer
    fileName = StrReplace(fileName, "$", "#")
    ActiveWorkbook.SaveAs fileName:=fileName + ".xls", FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
    SaveBook = 1
End Function

Sub LoadTable(lr As Range, lcTable As String)
Dim qt As QueryTable, n As Integer
    dbPath = IIf(dbPath = "", ThisWorkbook.Path + "\", dbPath)
    If Dir(dbPath + lcTable, vbNormal) <> "" Then
        lr.Parent.Activate
        
        If LoadVFPData(lr, dbPath, "SELECT * FROM " + lcTable, rowsCount, columnsCount, False) < 0 Then GoTo Err1
        
        GoTo ExitProc
Err1:
        n = MsgBox("Ошибка загрузки данных!", vbCritical + vbOKOnly, "Ошибка")
        Er = -1
ExitProc:
    End If
    Set qt = Nothing
End Sub

Sub PrintFile(lcFile As String, lnMode As Integer, lcStr As String)
    If lnMode = 0 Then
        Open lcFile For Output As #1
    Else
        Open lcFile For Append As #1
    End If
    Print #1, lcStr
    Close #1
End Sub


