Attribute VB_Name = "CALCULATE"
Option Explicit
' -------------------------------------------------------------------------------------------------------
' При вставке новой записи в бланк отчета
' перезаписываются адреса ячеек участвующих в формуле
' lnMode - True запись , False - удаление
' lnRow - номер вставленной (удаленной) записи Excel
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Sub READDRESS_FORMULA(ByVal lnInsertRow As Integer, ByVal lnMode As Integer)

Dim LookRange As Range
Dim nCnt, lnNumFormula As Integer
Dim lnColumn, lnRow As Long
Dim lcStrFormula, lcAddressNewRow, lcAddressOldRow, lcTextFormula As String
Dim lSheetsForm As Object

    On Error GoTo doError
    Set lSheetsForm = Sheets("Form")
    lnColumn = lSheetsForm.Range("TABLE_FORM").column

    Set LookRange = lSheetsForm.Columns(lnColumn).Find("", LookIn:=xlValues, lookat:=xlWhole, SearchOrder:=xlByRows)
    lnRow = LookRange.row
    If lnRow > 2 Then
    If lnMode Then ' перезапись адресов
        For nCnt = 2 To lnRow - 1
            'Получим текст формулы
            If Sheets("Service").Range("B20") = lSheetsForm.Cells(nCnt, lnColumn + 7) And lSheetsForm.Cells(nCnt, lnColumn + 6) <> 4 Then
                lcTextFormula = lSheetsForm.Cells(nCnt, lnColumn + 3)
                lcTextFormula = REPL_ADDRESS_ROW(lcTextFormula, lnInsertRow)
                lSheetsForm.Cells(nCnt, lnColumn + 3) = lcTextFormula
            End If
        Next
    Else ' Удаление
        lnRow = lnRow - 1
        nCnt = 2
        While nCnt <= lnRow
            If Sheets("Service").Range("B20") = lSheetsForm.Cells(nCnt, lnColumn + 7) And lSheetsForm.Cells(nCnt, lnColumn + 6) <> 4 Then
                'Получим текст формулы
                lcTextFormula = lSheetsForm.Cells(nCnt, lnColumn + 3)
                lnNumFormula = lSheetsForm.Cells(nCnt, lnColumn + 2)
                lcTextFormula = DEL_ADDRESS_ROW(lcTextFormula, lnInsertRow)
                If lcTextFormula <> "" Then ' Просто перезаписываем
                    lSheetsForm.Cells(nCnt, lnColumn + 3) = lcTextFormula
                Else ' Все не так просто - надо удалять формулу(алгоритм расчета если есть)
                    Call READDRESS_DEL_FORMULA(lnNumFormula)
                    lnRow = lnRow - 1
                End If
            End If
            nCnt = nCnt + 1
        Wend
    End If
    End If

    Exit Sub
doError:
    Call ERROR_EVENT("READDRESS_FORMULA")
End Sub
' -------------------------------------------------------------------------------------------------------
' Функция для удаления формулы, где есть адрес удаляемой ячейки (номера строки в Excel)
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Function DEL_ADDRESS_ROW(ByVal lcTextFormula As String, ByVal lnInsertRow As Long) As String
Dim lcResultFormula, lc1, lc2, lc3, lc4, lcFormu As String
Dim lnStart, lnEnd As Integer

On Error GoTo doError
lcFormu = lcTextFormula
' Будем смотреть каждый адрес
While VBA.Trim(lcFormu) <> ""
    lnStart = VBA.InStr(2, lcFormu, " ", vbTextCompare)
    lnEnd = VBA.InStr(lnStart + 1, lcFormu, " ", vbTextCompare)
    lc1 = VBA.Left(lcFormu, lnStart)
    lc2 = VBA.Mid(lcFormu, lnStart + 1, lnEnd - lnStart - 1)
    'Анализ второй части
    lc3 = VBA.Right(lc2, VBA.Len(lc2) - 2)
    lc4 = VBA.Left(lc2, 2)
    If VBA.Val(lc3) = lnInsertRow Then
        lc3 = VBA.Trim(VBA.str(VBA.Val(lc3) + 1))
        lc2 = lc4 + lc3
    Else
        'Запись нового текста
        lcResultFormula = lcResultFormula + lc1 + lc2
    End If
    lcFormu = VBA.Mid(lcFormu, lnEnd)
Wend
' Поменяем адреса ячеек
If VBA.Trim(lcResultFormula) = "" Then ' Формула пуста - надо удалять
    DEL_ADDRESS_ROW = ""
    Exit Function
Else
lcFormu = lcResultFormula + " "
lcResultFormula = ""
' Будем смотреть каждый адрес
    While VBA.Trim(lcFormu) <> ""
        lnStart = VBA.InStr(2, lcFormu, " ", vbTextCompare)
        lnEnd = VBA.InStr(lnStart + 1, lcFormu, " ", vbTextCompare)
        lc1 = VBA.Left(lcFormu, lnStart)
        lc2 = VBA.Mid(lcFormu, lnStart + 1, lnEnd - lnStart - 1)
        'Анализ второй части
        lc3 = VBA.Right(lc2, VBA.Len(lc2) - 2)
        lc4 = VBA.Left(lc2, 2)
        If VBA.Val(lc3) > lnInsertRow Then
            lc3 = VBA.Trim(VBA.str(VBA.Val(lc3) - 1))
            lc2 = lc4 + lc3
        End If
        'Запись нового текста
        lcResultFormula = lcResultFormula + lc1 + lc2
        lcFormu = VBA.Mid(lcFormu, lnEnd)
    Wend
End If
DEL_ADDRESS_ROW = lcResultFormula + " "

Exit Function
doError:
    Call ERROR_EVENT("DEL_ADDRESS_ROW")
End Function
' -------------------------------------------------------------------------------------------------------
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Function REPL_ADDRESS_ROW(ByVal lcTextFormula As String, ByVal lnInsertRow As Long) As String
Dim lcResultFormula, lc1, lc2, lc3, lc4, lcFormu As String
Dim lnStart, lnEnd As Integer

On Error GoTo doError

lcFormu = lcTextFormula
' Будем смотреть каждый адрес
While lcFormu <> " "
    lnStart = VBA.InStr(2, lcFormu, " ", vbTextCompare)
    lnEnd = VBA.InStr(lnStart + 1, lcFormu, " ", vbTextCompare)
    lc1 = VBA.Left(lcFormu, lnStart)
    lc2 = VBA.Mid(lcFormu, lnStart + 1, lnEnd - lnStart - 1)
    'Анализ второй части
    lc3 = VBA.Right(lc2, VBA.Len(lc2) - 2)
    lc4 = VBA.Left(lc2, 2)
    If VBA.Val(lc3) >= lnInsertRow Then
        lc3 = VBA.Trim(VBA.str(VBA.Val(lc3) + 1))
        lc2 = lc4 + lc3
    End If
    'Запись нового текста
    lcResultFormula = lcResultFormula + lc1 + lc2
    lcFormu = VBA.Mid(lcFormu, lnEnd)
Wend
REPL_ADDRESS_ROW = lcResultFormula + " "

Exit Function
doError:
    Call ERROR_EVENT("REPL_ADDRESS_ROW")
End Function
' -------------------------------------------------------------------------------------------------------
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Sub READDRESS_DEL_FORMULA(ByVal lnNumFormu As Long)
Dim lnLinkBar As Integer, lnNumGraf As Integer
Dim lbTrue As Boolean
Dim LookRange As Range
Dim lcRow As String

Dim lnColumn As Integer, lnColumnCount As Integer, lnRow As Integer
Dim lnColumn1 As Integer, lnColumnCount1 As Integer, lnRow1 As Integer, lnRowFirst As Long
Dim lSheetsAlg As Object, lSheetsForm As Object, lSheetsCond As Object
Set lSheetsAlg = Sheets("ALG")
Set lSheetsForm = Sheets("Form")
Set lSheetsCond = Sheets("OTBOR_COND")

On Error GoTo doError

With lSheetsCond
    lnColumn1 = .Range("KRIT_STR_COND").column
    lnColumnCount1 = .Range("KRIT_STR_COND").Columns.count
    lnRow1 = .Range("KRIT_STR_COND").row
End With

With lSheetsAlg
    lnColumn = .Range("TABLE_ALG").column
    lnColumnCount = .Range("TABLE_ALG").Columns.count
End With

Set LookRange = lSheetsAlg.Columns(lnColumn + 2).Find(lnNumFormu, LookIn:=xlValues)
If Not LookRange Is Nothing Then
    lnRowFirst = LookRange.row
    Do
        ' Посмотрим есть алгоритм расчета по условию для этого объекта
        lSheetsCond.Cells(lnRow1 + 1, lnColumn1 + 1) = lSheetsAlg.Cells(LookRange.row, lnColumn)
        lSheetsCond.Cells(lnRow1 + 1, lnColumn1 + 2) = lSheetsAlg.Cells(LookRange.row, lnColumn + 1)
        If lSheetsCond.Cells(lnRow1 + 2, lnColumn1 + 1) = 0 And lSheetsCond.Cells(lnRow1 + 2, lnColumn1 + 2) = 0 Then ' Есть условия
            'Ставим алгоритм по условию
            lSheetsAlg.Cells(LookRange.row, lnColumn + 2) = ""
            lSheetsAlg.Cells(LookRange.row, lnColumn + 3) = 1
        Else
            'Удаляем запись из БД TABLE_ALG
            With lSheetsAlg
                .Range(.Cells(LookRange.row, lnColumn), .Cells(LookRange.row, lnColumn + lnColumnCount - 1)).Delete Shift:=xlUp
            End With
        End If
        Set LookRange = lSheetsAlg.Columns(lnColumn + 2).Find(lnNumFormu, LookIn:=xlValues)
    Loop While Not LookRange Is Nothing
End If
' Обнуляем критерий TABLE_STR_COND
lSheetsCond.Range(lSheetsCond.Cells(lnRow1 + 1, lnColumn1), lSheetsCond.Cells(lnRow1 + 1, lnColumn1 + lnColumnCount1 - 2)) = ""
' Удаляем саму формулу из TABLE_FORM
With lSheetsForm
    lnColumn = .Range("KRIT_FORM").column
    lnColumnCount = .Range("KRIT_FORM").Columns.count
    lnRow = .Range("KRIT_FORM").row
    'Запись в критерий
    .Cells(lnRow + 1, lnColumn + 2) = lnNumFormu
    lSheetsForm.Visible = True
    lnRow1 = .Cells(lnRow + 4, lnColumn) ' Символьный номер записи в Excel формулы
    ' Очистка критерия
    .Range(.Cells(lnRow + 1, lnColumn), .Cells(lnRow + 1, lnColumn + lnColumnCount - 2)) = ""
    ' Удаление из TABLE_FORM
    lnColumn = .Range("TABLE_FORM").column
    lnColumnCount = .Range("TABLE_FORM").Columns.count
    .Range(.Cells(lnRow1, lnColumn), .Cells(lnRow1, lnColumn + lnColumnCount - 1)).Delete Shift:=xlUp
End With

Exit Sub
doError:
    Call ERROR_EVENT("READDRESS_DEL_FORMULA")
End Sub
' -------------------------------------------------------------------------------------------------------
