'макрос на открытие книги
Option Explicit
Private Sub Workbook_Open()
Application.Calculation = xlCalculationManual
End Sub

'основной макрос (лист ведомости)
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim i&, r&, c&, temp, txt1$, txt2$
Dim rBal, sBal
Dim minus, strType$
Cancel = 1: Application.ScreenUpdating = 0: Application.Calculate
r = Target.Row: c = Target.Column: If r = 1 Or c < 4 Or c > 5 Then Exit Sub Else strType = Cells(r, 15).Value2
    If c = 4 Then
        If strType = "Р" Then
            If Len(Target.Value2) Then Target.Value2 = "": Target.Interior.Color = xlNone Else Target.Value2 = "a": Target.Interior.Color = PPP_colorGood
        ElseIf strType = "С" Then
            If Len(Target.Value2) Then Target.Value2 = "": Target.Interior.Color = xlNone Else Target.Value2 = "r": Target.Interior.Color = PPP_colorBad
        End If
    Else
        If strType <> "Р" Then GoTo fin Else rBal = Cells(r, c + 4).Value2
            If Len(rBal) Then
                If rBal < 0 Then MsgBox "Остаток по расценке не может быть отрицательным!", vbCritical, "ОШИБКА СПИСЫВАНИЯ": GoTo fin
                    If rBal = 0 Then
                        If MsgBox("Остаток по расценке равен НУЛЮ!" & vbLf & vbLf & "Вы действительно хотите продолжить?…", vbYesNo + vbExclamation + vbDefaultButton2) = vbNo Then GoTo fin
                    End If
            Else
                rBal = Cells(r, c + 2).Value2
            End If
            If shSpec.bOnlyFree.Value = True Then
                Call PRDX_FormSearch_Start(FILE_UpdateSpec(), "СПЕЦИФИКАЦИИ (свободные)", 0, 1)
            Else
                Call PRDX_FormSearch_Start(FILE_UpdateSpec(), "СПЕЦИФИКАЦИИ (доступные)", 0, 1)
            End If
        If PPP_FormSearch_index < 0 Then GoTo fin
        txt1 = Cells(r, c + 1).Value2: txt2 = PRDX_DelByBorder(PRDX_DelByBorder(PPP_FormSearch_value, "; ["), "]", 1)
            If txt1 <> txt2 Then
                If MsgBox("Единицы измерения РАСЦЕНКИ «[" & txt1 & "]» и СПЕЦИФИКАЦИИ «[" & txt2 & "]» не равны!" & vbLf & vbLf & "Продолжить?", vbYesNo + vbExclamation + vbDefaultButton2) = vbNo Then GoTo fin
            End If
        Cells(r + 1, 1).EntireRow.Insert
        Cells(r + 1, c).Value2 = PRDX_DelByBorder(PPP_FormSearch_value, " | ID-"): Cells(r + 1, c + 1).Value2 = txt2
        sBal = --PRDX_DelByBorder(PRDX_DelByBorder(PPP_FormSearch_value, "] = "), " из ", 1)
        If rBal > sBal Then Cells(r + 1, c + 2).Value2 = sBal Else Cells(r + 1, c + 2).Value2 = rBal
        Cells(r + 1, c).Resize(1, 5).Interior.Color = PPP_colorBluePurpLight
    End If
fin: Application.Calculate: Application.ScreenUpdating = 1
End Sub


'макрос из листа спецификаций
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [_specNo]) Is Nothing Then Exit Sub Else Cancel = 1
    If Len(Target.Value2) Then
        Target.Value2 = "": Target.Resize(1, 2).Interior.Color = xlNone
    Else
        Target.Value2 = "a": Target.Resize(1, 2).Interior.Color = PPP_colorGrayLight
    End If
Application.Calculate
End Sub


'Отдельный модуль в книге
Option Explicit
'===========================================================================================
Public Function FILE_UpdateSpec()
Dim tempCheck, tempKey, arrKey, x, i&, n&
tempCheck = [_specCheck].Value2: tempKey = [_specKey].Value2: ReDim arrKey(0 To UBound(tempCheck, 1)): i = 0: n = -1
    If shSpec.bOnlyFree.Value = True Then
        For Each x In tempCheck
            i = i + 1: If x = "СВОБОДНО" Then n = n + 1: arrKey(n) = tempKey(i, 1)
        Next x
    Else
        For Each x In tempCheck
            i = i + 1: If InStr(1, "СВОБОДНО | ДОСТУПНО", x) Then n = n + 1: arrKey(n) = tempKey(i, 1)
        Next x
    End If
If n = -1 Then MsgBox "Нет свободных спецификаций!", vbExclamation, "«FILE_UpdateSpec»": Exit Function
ReDim Preserve arrKey(0 To n): FILE_UpdateSpec = PRDX_ArraySort(arrKey)
End Function