Есть книга, в которой я хочу на событие книги Пересчёт листа (Private Sub Workbook_SheetCalculate) повесить запуск своего макроса. В этом макросе присутствуют пересчёты книги Application.Calculate и, чтобы они снова не вызывали событие в цикле, я отключаю их с помощью Application.EnableEvents=False. Вроде всё логично…
В тестовом файле «Событие пересчёта» воспроизведённый случай отработал без проблем:
Код
Option Explicit
Dim n&
'===========================================================================================
Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
Dim flag As Boolean
Application.EnableEvents = False
n = 1: [a1].Value2 = n
MsgBox n & " — " & [c1].Value2
Application.Calculate
MsgBox n & " — " & [c1].Value2
t1
t2
n = 4: [a1].Value2 = n
MsgBox n & " — " & [c1].Value2
Application.Calculate
MsgBox n & " — " & [c1].Value2
Application.EnableEvents = True
End Sub
'===========================================================================================
Sub t1()
n = 2: [a1].Value2 = n
MsgBox n & " — " & [c1].Value2
Application.Calculate
MsgBox n & " — " & [c1].Value2
End Sub
'===========================================================================================
Sub t2()
n = 3: [a1].Value2 = n
MsgBox n & " — " & [c1].Value2
Application.Calculate
MsgBox n & " — " & [c1].Value2
End Sub
'===========================================================================================
Проблема в том, что в рабочем файле (сюда скинуть не могу) он работает по-другому, а именно, после включения событий обратно (Application.EnableEvents=True), он не просто их (события) включает, но и запускает, тем самым образуя цикл…
Модуль книги с событием
Код
Option Explicit
'===========================================================================================
Private Sub Workbook_Open()
Application.Calculation = xlCalculationManual
End Sub
'===========================================================================================
Private Sub Workbook_SheetBeforeDoubleClick(ByVal sh As Object, ByVal Target As Range, Cancel As Boolean)
Cancel = True: FILE_FRM_Search_Process.StartFilter
End Sub
'===========================================================================================
Private Sub Workbook_SheetCalculate(ByVal sh As Object)
Dim t!
Static flag1 As Boolean, flag2 As Boolean
If flag1 Then
If flag2 Then flag2 = False: Exit Sub
End If
If Application.CutCopyMode Then Exit Sub
t = Timer: Application.EnableEvents = False
If Not FILE_TableFill_All() Then GoTo fin
If FILE_TableCheck_All Then MsgBox "Все таблицы успешно перезаполнены и проверены!", vbInformation, Format$(Timer - t, "0.00 сек")
fin: Application.EnableEvents = True: flag1 = True
End Sub
Модуль с аналогами функций листа на макросах (ВПР и СУММЕСЛИ)
Код
Option Explicit
Option Private Module
'====================================================================================================
Function FILE_Match(rngPosInput As Range, rngKeys As Range, rngPosGet As Range) As Boolean
Dim dic As New Dictionary
Dim arr, r&
rngPosInput.Value2 = FFF_dash
If rngPosInput.Count <> rngKeys.Count Then MsgBox "Диапазоны КЛЮЧЕЙ и ВСТАВКИ должны быть РАВНЫ!", vbCritical, "FILE_Match": Exit Function
If rngPosInput.Areas.Count <> 1 Or rngKeys.Areas.Count <> 1 Or rngPosGet.Areas.Count <> 1 Then MsgBox "Не более ОДНОЙ ОБЛАСТИ для каждого из диапазонов!", vbCritical, "FILE_Match": Exit Function
If rngPosInput.Columns.Count <> 1 Or rngKeys.Columns.Count <> 1 Or rngPosGet.Columns.Count <> 1 Then MsgBox "Не более ОДНОГО СТОЛБЦА для каждого из диапазонов!", vbCritical, "FILE_Match": Exit Function
arr = rngPosGet.Value2
If Not IsArray(arr) Then
If Len(arr) > 0 And arr <> FFF_dash Then dic(arr) = 1
Else
For r = 1 To UBound(arr, 1)
If Len(arr(r, 1)) > 0 And arr(r, 1) <> FFF_dash Then dic(arr(r, 1)) = r
Next r
End If
arr = rngKeys.Value2
If Not IsArray(arr) Then
If dic.Exists(arr) Then
arr = dic(arr)
Else
If Len(arr) = 0 Or arr = FFF_dash Then arr = FFF_dash Else MsgBox "Ключ «" & arr & "» в источнике НЕ НАЙДЕН!", vbCritical, "FILE_Match": Exit Function
End If
Else
For r = 1 To UBound(arr, 1)
If dic.Exists(arr(r, 1)) Then
arr(r, 1) = dic(arr(r, 1))
Else
If Len(arr(r, 1)) = 0 Or arr(r, 1) = FFF_dash Then arr(r, 1) = FFF_dash Else MsgBox "Ключ «" & arr(r, 1) & "» в источнике НЕ НАЙДЕН!", vbCritical, "FILE_Match": Exit Function
End If
Next r
End If
rngPosInput.Value2 = arr
FILE_Match = True
End Function
'====================================================================================================
Function FILE_SumIf(rngSumInput As Range, rngKeysInput As Range, rngKeysGet As Range, rngSumGet As Range) As Boolean
Dim dic As New Dictionary
Dim arr, arr2, r&
rngSumInput.ClearContents
If rngSumInput.Count <> rngKeysInput.Count Or rngKeysGet.Count <> rngSumGet.Count Then MsgBox "Попарные диапазоны должны быть РАВНЫ!", vbCritical, "FILE_SumIf": Exit Function
If rngSumInput.Areas.Count <> 1 Or rngKeysInput.Areas.Count <> 1 Or rngKeysGet.Areas.Count <> 1 Or rngSumGet.Areas.Count <> 1 Then MsgBox "Не более ОДНОЙ ОБЛАСТИ для каждого из диапазонов!", vbCritical, "FILE_SumIf": Exit Function
If rngSumInput.Columns.Count <> 1 Or rngKeysInput.Columns.Count <> 1 Or rngKeysGet.Columns.Count <> 1 Or rngSumGet.Columns.Count <> 1 Then MsgBox "Не более ОДНОГО СТОЛБЦА для каждого из диапазонов!", vbCritical, "FILE_SumIf": Exit Function
arr = rngKeysGet.Value2
arr2 = rngSumGet.Value2
If Not IsArray(arr) Then
If Len(arr) > 0 And arr <> FFF_dash Then dic(arr) = arr2
Else
For r = 1 To UBound(arr, 1)
If Len(arr(r, 1)) > 0 And arr(r, 1) <> FFF_dash Then dic(arr(r, 1)) = dic(arr(r, 1)) + arr2(r, 1)
Next r
End If
arr2 = 0: arr = rngKeysInput.Value2
If Not IsArray(arr) Then
If dic.Exists(arr) Then arr = dic(arr) Else arr = 0
Else
For r = 1 To UBound(arr, 1)
If dic.Exists(arr(r, 1)) Then arr(r, 1) = dic(arr(r, 1)) Else arr(r, 1) = 0
Next r
End If
rngSumInput.Value2 = arr
FILE_SumIf = True
End Function
'====================================================================================================
Function FILE_SumIfCrit(rngSumInput As Range, rngKeysInput As Range, rngKeysGet As Range, rngCritGet As Range, crit, rngSumGet As Range) As Boolean
Dim dic As New Dictionary
Dim arr, arr1, arr2, r&
rngSumInput.ClearContents
If rngSumInput.Count <> rngKeysInput.Count Or rngKeysGet.Count <> rngCritGet.Count Or rngKeysGet.Count <> rngSumGet.Count Then MsgBox "Попарные диапазоны должны быть РАВНЫ!", vbCritical, "FILE_SumIf": Exit Function
If rngSumInput.Areas.Count <> 1 Or rngKeysInput.Areas.Count <> 1 Or rngKeysGet.Areas.Count <> 1 Or rngCritGet.Areas.Count <> 1 Or rngSumGet.Areas.Count <> 1 Then MsgBox "Не более ОДНОЙ ОБЛАСТИ для каждого из диапазонов!", vbCritical, "FILE_SumIf": Exit Function
If rngSumInput.Columns.Count <> 1 Or rngKeysInput.Columns.Count <> 1 Or rngKeysGet.Columns.Count <> 1 Or rngCritGet.Columns.Count <> 1 Or rngSumGet.Columns.Count <> 1 Then MsgBox "Не более ОДНОГО СТОЛБЦА для каждого из диапазонов!", vbCritical, "FILE_SumIf": Exit Function
arr = rngKeysGet.Value2
arr1 = rngCritGet.Value2
arr2 = rngSumGet.Value2
If Not IsArray(arr) Then
If Len(arr) > 0 And arr <> FFF_dash And arr1 = crit Then dic(arr) = arr2
Else
For r = 1 To UBound(arr, 1)
If Len(arr(r, 1)) > 0 And arr(r, 1) <> FFF_dash And arr1(r, 1) = crit Then dic(arr(r, 1)) = dic(arr(r, 1)) + arr2(r, 1)
Next r
End If
arr1 = 0: arr2 = 0: arr = rngKeysInput.Value2
If Not IsArray(arr) Then
If dic.Exists(arr) Then arr = dic(arr) Else arr = 0
Else
For r = 1 To UBound(arr, 1)
If dic.Exists(arr(r, 1)) Then arr(r, 1) = dic(arr(r, 1)) Else arr(r, 1) = 0
Next r
End If
rngSumInput.Value2 = arr
FILE_SumIfCrit = True
End Function
Модуль с функциями для заполнения диапазонов листа (FILE_TableFill_All)
Код
Option Explicit
Option Private Module
'====================================================================================================
'====================================================================================================
Function FILE_TableFill_All() As Boolean
If Not FILE_TableFill_Pos() Then MsgBox 1: GoTo er
If Not FILE_TableFill_Done() Then MsgBox 2: GoTo er
Application.Calculate
If Not FILE_TableFill_WO() Then MsgBox 3: GoTo er
Application.Calculate
If Not FILE_TableFill_Act() Then MsgBox 4: GoTo er
If Not FILE_TableFill_Bud() Then MsgBox 5: GoTo er
If Not FILE_TableFill_Cntr() Then MsgBox 6: GoTo er
Application.Calculate
If Not FILE_TableFill_Layer() Then MsgBox 7: GoTo er
If Not FILE_TableFill_Part() Then MsgBox 4: GoTo er
Application.Calculate
If Not FILE_TableFill_Est() Then MsgBox 5: GoTo er
FILE_TableFill_All = True: Exit Function
er: MsgBox "При заполнении таблиц возникли ошибки…", vbCritical, "FILE_TableFill_All"
End Function
'====================================================================================================
Function FILE_TableFill(shName$) As Boolean
If shName = shAct.Name Then
If FILE_TableFill_Act() Then FILE_TableFill = True
ElseIf shName = shBud.Name Then
If FILE_TableFill_Bud() Then FILE_TableFill = True
ElseIf shName = shCntr.Name Then
If FILE_TableFill_Cntr() Then FILE_TableFill = True
ElseIf shName = shDone.Name Then
If FILE_TableFill_Done() Then FILE_TableFill = True
ElseIf shName = shEst.Name Then
If FILE_TableFill_Est() Then FILE_TableFill = True
ElseIf shName = shLayer.Name Then
If FILE_TableFill_Layer() Then FILE_TableFill = True
ElseIf shName = shPart.Name Then
If FILE_TableFill_Part() Then FILE_TableFill = True
ElseIf shName = shPos.Name Then
If FILE_TableFill_Pos() Then FILE_TableFill = True
ElseIf shName = shWO.Name Then
If FILE_TableFill_WO() Then FILE_TableFill = True
Else
MsgBox "Лист «" & shName & "» НЕ РАСПОЗНАН!", vbCritical, "FILE_TableFill"
End If
End Function
'====================================================================================================
'====================================================================================================
Function FILE_TableFill_Act() As Boolean
If FILE_TableIsEmpty(shAct.ListObjects(1)) Then FILE_TableFill_Act = True: Exit Function
If Not FILE_SumIf([_actSumDone], [_actKey], [_doneAct], [_doneSum]) Then Exit Function
FILE_TableFill_Act = True
End Function
'====================================================================================================
Function FILE_TableFill_Bud() As Boolean
If FILE_TableIsEmpty(shBud.ListObjects(1)) Then FILE_TableFill_Bud = True: Exit Function
If Not FILE_SumIf([_budSumTotal], [_budKey], [_posBud], [_posCostE]) Then Exit Function
If Not FILE_SumIf([_budSumCntr], [_budKey], [_WOBud], [_WOdoneSumCntr]) Then Exit Function
If Not FILE_SumIf([_budSumEst], [_budKey], [_WOBud], [_WOdoneSumEst]) Then Exit Function
If Not FILE_SumIf([_budSumFact], [_budKey], [_WOBud], [_WOdoneSumFact]) Then Exit Function
FILE_TableFill_Bud = True
End Function
'====================================================================================================
Function FILE_TableFill_Cntr() As Boolean
If FILE_TableIsEmpty(shCntr.ListObjects(1), True) Then Exit Function
If Not FILE_Match([_cntrMatch], [_cntrLayer], [_layerKey]) Then Exit Function
If Not FILE_SumIf([_cntrC], [_cntrKey], [_WOcntrKey], [_WOcostC]) Then Exit Function
If Not FILE_SumIf([_cntrE], [_cntrKey], [_WOcntrKey], [_WOcostE]) Then Exit Function
FILE_TableFill_Cntr = True
End Function
'====================================================================================================
Function FILE_TableFill_Done() As Boolean
If FILE_TableIsEmpty(shDone.ListObjects(1)) Then FILE_TableFill_Done = True: Exit Function
If Not FILE_Match([_doneMatchA], [_doneAct], [_actKey]) Then Exit Function
If Not FILE_Match([_doneMatchC], [_doneWOkeyGen], [_WOkeyGen]) Then Exit Function
FILE_TableFill_Done = True
End Function
'====================================================================================================
Function FILE_TableFill_Est() As Boolean
If FILE_TableIsEmpty(shEst.ListObjects(1), True) Then Exit Function
If Not FILE_SumIf([_estSumTotal], [_estKey], [_partEst], [_partSumTotal]) Then Exit Function
If Not FILE_SumIf([_estSumCntr], [_estKey], [_partEst], [_partSumCntr]) Then Exit Function
If Not FILE_SumIf([_estSumEst], [_estKey], [_partEst], [_partSumEst]) Then Exit Function
If Not FILE_SumIf([_estSumFact], [_estKey], [_partEst], [_partSumFact]) Then Exit Function
FILE_TableFill_Est = True
End Function
'====================================================================================================
Function FILE_TableFill_Layer() As Boolean
If FILE_TableIsEmpty(shLayer.ListObjects(1), True) Then Exit Function
If Not FILE_SumIf([_layerC], [_layerKey], [_cntrLayer], [_cntrC]) Then Exit Function
If Not FILE_SumIf([_layerE], [_layerKey], [_cntrLayer], [_cntrE]) Then Exit Function
FILE_TableFill_Layer = True
End Function
'====================================================================================================
Function FILE_TableFill_Part() As Boolean
If FILE_TableIsEmpty(shPart.ListObjects(1), True) Then Exit Function
If Not FILE_SumIf([_partSumTotal], [_partKey], [_posPart], [_posCostE]) Then Exit Function
If Not FILE_SumIf([_partSumCntr], [_partKey], [_WOPart], [_WOdoneSumCntr]) Then Exit Function
If Not FILE_SumIf([_partSumEst], [_partKey], [_WOPart], [_WOdoneSumEst]) Then Exit Function
If Not FILE_SumIf([_partSumFact], [_partKey], [_WOPart], [_WOdoneSumFact]) Then Exit Function
FILE_TableFill_Part = True
End Function
'====================================================================================================
Function FILE_TableFill_Pos() As Boolean
If FILE_TableIsEmpty(shPos.ListObjects(1), True) Then Exit Function
If Not FILE_SumIf([_posValWO], [_posKeyGen], [_WOposGen], [_WOval]) Then Exit Function
FILE_TableFill_Pos = True
End Function
'====================================================================================================
Function FILE_TableFill_WO() As Boolean
If FILE_TableIsEmpty(shWO.ListObjects(1), True) Then Exit Function
If Not FILE_Match([_WOmatchC], [_WOcntrKey], [_cntrKey]) Then Exit Function
If Not FILE_Match([_WOmatchP], [_WOposGen], [_posKeyGen]) Then Exit Function
If Not FILE_SumIfCrit([_WOdoneValFact], [_WOkeyGen], [_doneWOkeyGen], [_doneType], "ФАКТ", [_doneVal]) Then Exit Function
If Not FILE_SumIfCrit([_WOdoneValCntr], [_WOkeyGen], [_doneWOkeyGen], [_doneType], "ПОДРЯДЧИК", [_doneVal]) Then Exit Function
If Not FILE_SumIfCrit([_WOdoneValEst], [_WOkeyGen], [_doneWOkeyGen], [_doneType], "ЗАКАЗЧИК", [_doneVal]) Then Exit Function
FILE_TableFill_WO = True
End Function
Модуль с функциями проверки таблиц (FILE_TableCheck_All)
Код
Option Explicit
Option Private Module
'====================================================================================================
'====================================================================================================
Function FILE_TablePresentOnSheet(ByVal sh As Worksheet, Optional MsgIfFalse As Boolean) As Boolean
Dim tbl As ListObject
On Error Resume Next: Set tbl = sh.ListObjects(1): If Err.Number = 0 Then FILE_TablePresentOnSheet = True: Exit Function
If MsgIfFalse Then MsgBox "Таблица на листе «" & sh.Name & "» НЕ НАЙДЕНА!", vbCritical, "FILE_TablePresentOnSheet"
End Function
'====================================================================================================
Function FILE_TableIsEmpty(ByVal tbl As ListObject, Optional MsgIfTrue As Boolean, Optional MsgIfFalse As Boolean) As Boolean
If tbl.DataBodyRange Is Nothing Then
FILE_TableIsEmpty = True: If MsgIfTrue Then MsgBox "Таблица «" & tbl.Name & "» на листе «" & tbl.Parent.Name & "» — ПУСТАЯ!", vbInformation, "FILE_TableIsEmpty"
Else
If MsgIfFalse Then MsgBox "Таблица «" & tbl.Name & "» на листе «" & tbl.Parent.Name & "» — НЕ ПУСТАЯ!", vbExclamation, "FILE_TableIsEmpty"
End If
End Function
'====================================================================================================
Function FILE_TableResize(ByVal tbl As ListObject, rowPlus&, Optional colPlus&) As Boolean
Dim rOld&, cOld&, rNew&, cNew&
rOld = tbl.Range.Rows.Count - 1: cOld = tbl.Range.Columns.Count
rNew = rOld + rowPlus: If rNew < 1 Then MsgBox "В умной таблице не может быть меньше 1 строки", vbCritical, "FILE_TableResize": Exit Function
cNew = cOld + colPlus: If cNew < 1 Then MsgBox "В умной таблице не может быть меньше 1 столбца", vbCritical, "FILE_TableResize": Exit Function
tbl.Resize tbl.Range(1, 1).Resize(rNew + 1, cNew)
FILE_TableResize = True
End Function
'====================================================================================================
'====================================================================================================
Function FILE_TableCheck_All() As Boolean
If Not FILE_TableCheck_Act() Then MsgBox 1: GoTo er
If Not FILE_TableCheck_Bud() Then MsgBox 2: GoTo er
If Not FILE_TableCheck_Cntr() Then MsgBox 3: GoTo er
If Not FILE_TableCheck_Done() Then MsgBox 4: GoTo er
If Not FILE_TableCheck_Est() Then MsgBox 5: GoTo er
If Not FILE_TableCheck_Layer() Then MsgBox 6: GoTo er
If Not FILE_TableCheck_Part() Then MsgBox 7: GoTo er
If Not FILE_TableCheck_Pos() Then MsgBox 8: GoTo er
If Not FILE_TableCheck_WO() Then MsgBox 9: GoTo er
FILE_TableCheck_All = True: Exit Function
er: MsgBox "При проверке таблиц возникли ошибки…", vbCritical, "FILE_TableCheck_All"
End Function
'====================================================================================================
Function FILE_TableCheck(shName$) As Boolean
If shName = shAct.Name Then
If FILE_TableCheck_Act() Then FILE_TableCheck = True
ElseIf shName = shBud.Name Then
If FILE_TableCheck_Bud() Then FILE_TableCheck = True
ElseIf shName = shCntr.Name Then
If FILE_TableCheck_Cntr() Then FILE_TableCheck = True
ElseIf shName = shDone.Name Then
If FILE_TableCheck_Done() Then FILE_TableCheck = True
ElseIf shName = shEst.Name Then
If FILE_TableCheck_Est() Then FILE_TableCheck = True
ElseIf shName = shLayer.Name Then
If FILE_TableCheck_Layer() Then FILE_TableCheck = True
ElseIf shName = shPart.Name Then
If FILE_TableCheck_Part() Then FILE_TableCheck = True
ElseIf shName = shPos.Name Then
If FILE_TableCheck_Pos() Then FILE_TableCheck = True
ElseIf shName = shWO.Name Then
If FILE_TableCheck_WO() Then FILE_TableCheck = True
Else
MsgBox "Лист «" & shName & "» НЕ РАСПОЗНАН!", vbCritical, "FILE_TableCheck"
End If
End Function
'====================================================================================================
'====================================================================================================
Function FILE_TableCheck_Act() As Boolean
Dim sh As Worksheet, dic As New Dictionary
Dim arr, r&, c&
Set sh = shAct: If FILE_TableIsEmpty(sh.ListObjects(1)) Then FILE_TableCheck_Act = True: Exit Function
arr = sh.ListObjects(1).DataBodyRange.Value2
For c = 2 To UBound(arr, 2)
If Not "-7-8-" Like "*-" & c & "-*" Then
For r = 1 To UBound(arr, 1)
If IsError(arr(r, c)) Then sh.Select: MsgBox "Ячейка в строке №" & r + 1 & " столбца «" & sh.Cells(1, c) & "» содержит ОШИБКУ!", vbCritical, "Таблица на листе «" & sh.Name & "» ": Exit Function
If Len(arr(r, c)) = 0 Then sh.Select: MsgBox "Ячейка в строке №" & r + 1 & " столбца «" & sh.Cells(1, c) & "» ПУСТАЯ!", vbCritical, "Таблица на листе «" & sh.Name & "» ": Exit Function
Next r
End If
Next c
On Error GoTo dupl: c = [_actKey].Column
For r = 1 To UBound(arr, 1)
dic.Add arr(r, c), 0
Next r
FILE_TableCheck_Act = True: Exit Function
dupl: sh.Select: MsgBox "Ключ в строке №" & r + 1 & " столбца «" & sh.Cells(1, c) & "» — ДУБЛЬ!", vbCritical, "Таблица на листе «" & sh.Name & "» "
End Function
'====================================================================================================
Function FILE_TableCheck_Bud() As Boolean
Dim sh As Worksheet, dic As New Dictionary
Dim arr, r&, c&
Set sh = shBud: If FILE_TableIsEmpty(sh.ListObjects(1)) Then FILE_TableCheck_Bud = True: Exit Function
arr = sh.ListObjects(1).DataBodyRange.Value2
For c = 1 To UBound(arr, 2)
For r = 1 To UBound(arr, 1)
If IsError(arr(r, c)) Then sh.Select: MsgBox "Ячейка в строке №" & r + 1 & " столбца «" & sh.Cells(1, c) & "» содержит ОШИБКУ!", vbCritical, "Таблица на листе «" & sh.Name & "» ": Exit Function
If Len(arr(r, c)) = 0 Then sh.Select: MsgBox "Ячейка в строке №" & r + 1 & " столбца «" & sh.Cells(1, c) & "» ПУСТАЯ!", vbCritical, "Таблица на листе «" & sh.Name & "» ": Exit Function
Next r
Next c
On Error GoTo dupl: c = 1
For r = 1 To UBound(arr, 1)
dic.Add arr(r, c), 0
Next r
FILE_TableCheck_Bud = True: Exit Function
dupl: sh.Select: MsgBox "Ключ в строке №" & r + 1 & " столбца «" & sh.Cells(1, c) & "» — ДУБЛЬ!", vbCritical, "Таблица на листе «" & sh.Name & "» "
End Function
'====================================================================================================
Function FILE_TableCheck_Cntr() As Boolean
Dim sh As Worksheet, dic As New Dictionary
Dim arr, r&, c&
Set sh = shCntr: If FILE_TableIsEmpty(sh.ListObjects(1), True) Then Exit Function
arr = sh.ListObjects(1).DataBodyRange.Value2
For c = 1 To UBound(arr, 2)
If Not "-3-4-" Like "*-" & c & "-*" Then
For r = 1 To UBound(arr, 1)
If IsError(arr(r, c)) Then sh.Select: MsgBox "Ячейка в строке №" & r + 1 & " столбца «" & sh.Cells(1, c) & "» содержит ОШИБКУ!", vbCritical, "Таблица на листе «" & sh.Name & "» ": Exit Function
If Len(arr(r, c)) = 0 Then sh.Select: MsgBox "Ячейка в строке №" & r + 1 & " столбца «" & sh.Cells(1, c) & "» ПУСТАЯ!", vbCritical, "Таблица на листе «" & sh.Name & "» ": Exit Function
Next r
End If
Next c
For r = 1 To UBound(arr, 1)
c = -(Len(arr(r, 3)) = 0) - (Len(arr(r, 4)) = 0)
If c <> 1 Then sh.Select: MsgBox "В строке №" & r + 1 & " поля выбора (столбцы 3 и 4) заполнены НЕКОРРЕКТНО!", vbCritical, "Таблица на листе «" & sh.Name & "» ": Exit Function
Next r
On Error GoTo dupl: c = 2
For r = 1 To UBound(arr, 1)
dic.Add arr(r, c), 0
Next r
FILE_TableCheck_Cntr = True: Exit Function
dupl: sh.Select: MsgBox "Ключ в строке №" & r + 1 & " столбца «" & sh.Cells(1, c) & "» — ДУБЛЬ!", vbCritical, "Таблица на листе «" & sh.Name & "» "
End Function
'====================================================================================================
Function FILE_TableCheck_Done() As Boolean
Dim sh As Worksheet, dic As New Dictionary
Dim arr, r&, c&
Set sh = shDone: If FILE_TableIsEmpty(sh.ListObjects(1)) Then FILE_TableCheck_Done = True: Exit Function
arr = sh.ListObjects(1).DataBodyRange.Value2
For c = 4 To UBound(arr, 2)
For r = 1 To UBound(arr, 1)
If IsError(arr(r, c)) Then sh.Select: MsgBox "Ячейка в строке №" & r + 1 & " столбца «" & sh.Cells(1, c) & "» содержит ОШИБКУ!", vbCritical, "Таблица на листе «" & sh.Name & "» ": Exit Function
If Len(arr(r, c)) = 0 Then sh.Select: MsgBox "Ячейка в строке №" & r + 1 & " столбца «" & sh.Cells(1, c) & "» ПУСТАЯ!", vbCritical, "Таблица на листе «" & sh.Name & "» ": Exit Function
Next r
Next c
For r = 1 To UBound(arr, 1)
c = -(Len(arr(r, 2)) = 0) - (Len(arr(r, 3)) = 0)
If c <> 1 Then sh.Select: MsgBox "В строке №" & r + 1 & " поля выбора (столбцы 2 и 3) заполнены НЕКОРРЕКТНО!", vbCritical, "Таблица на листе «" & sh.Name & "» ": Exit Function
Next r
On Error GoTo dupl: c = [_doneKeyGen].Column
For r = 1 To UBound(arr, 1)
dic.Add arr(r, c), 0
Next r
dic.RemoveAll: c = [_doneKey].Column
For r = 1 To UBound(arr, 1)
dic.Add arr(r, c), 0
Next r
FILE_TableCheck_Done = True: Exit Function
dupl: sh.Select: MsgBox "Ключ в строке №" & r + 1 & " столбца «" & sh.Cells(1, c) & "» — ДУБЛЬ!", vbCritical, "Таблица на листе «" & sh.Name & "» "
End Function
'====================================================================================================
Function FILE_TableCheck_Est() As Boolean
Dim sh As Worksheet, dic As New Dictionary
Dim arr, r&, c&
Set sh = shEst: If FILE_TableIsEmpty(sh.ListObjects(1), True) Then Exit Function
arr = sh.ListObjects(1).DataBodyRange.Value2
For c = 1 To UBound(arr, 2)
For r = 1 To UBound(arr, 1)
If IsError(arr(r, c)) Then sh.Select: MsgBox "Ячейка в строке №" & r + 1 & " столбца «" & sh.Cells(1, c) & "» содержит ОШИБКУ!", vbCritical, "Таблица на листе «" & sh.Name & "» ": Exit Function
If Len(arr(r, c)) = 0 Then sh.Select: MsgBox "Ячейка в строке №" & r + 1 & " столбца «" & sh.Cells(1, c) & "» ПУСТАЯ!", vbCritical, "Таблица на листе «" & sh.Name & "» ": Exit Function
Next r
Next c
On Error GoTo dupl: c = 1
For r = 1 To UBound(arr, 1)
dic.Add arr(r, c), 0
Next r
FILE_TableCheck_Est = True: Exit Function
dupl: sh.Select: MsgBox "Ключ в строке №" & r + 1 & " столбца «" & sh.Cells(1, c) & "» — ДУБЛЬ!", vbCritical, "Таблица на листе «" & sh.Name & "» "
End Function
'====================================================================================================
Function FILE_TableCheck_Layer() As Boolean
Dim sh As Worksheet, dic As New Dictionary
Dim arr, r&, c&
Set sh = shLayer: If FILE_TableIsEmpty(sh.ListObjects(1), True) Then Exit Function
arr = sh.ListObjects(1).DataBodyRange.Value2
For c = 1 To UBound(arr, 2)
For r = 1 To UBound(arr, 1)
If IsError(arr(r, c)) Then sh.Select: MsgBox "Ячейка в строке №" & r + 1 & " столбца «" & sh.Cells(1, c) & "» содержит ОШИБКУ!", vbCritical, "Таблица на листе «" & sh.Name & "» ": Exit Function
If Len(arr(r, c)) = 0 Then sh.Select: MsgBox "Ячейка в строке №" & r + 1 & " столбца «" & sh.Cells(1, c) & "» ПУСТАЯ!", vbCritical, "Таблица на листе «" & sh.Name & "» ": Exit Function
Next r
Next c
On Error GoTo dupl: c = 1
For r = 1 To UBound(arr, 1)
dic.Add arr(r, c), 0
Next r
FILE_TableCheck_Layer = True: Exit Function
dupl: sh.Select: MsgBox "Ключ в строке №" & r + 1 & " столбца «" & sh.Cells(1, c) & "» — ДУБЛЬ!", vbCritical, "Таблица на листе «" & sh.Name & "» "
End Function
'====================================================================================================
Function FILE_TableCheck_Part() As Boolean
Dim sh As Worksheet, dic As New Dictionary
Dim arr, r&, c&
Set sh = shPart: If FILE_TableIsEmpty(sh.ListObjects(1), True) Then Exit Function
arr = sh.ListObjects(1).DataBodyRange.Value2
For c = 1 To UBound(arr, 2)
For r = 1 To UBound(arr, 1)
If IsError(arr(r, c)) Then sh.Select: MsgBox "Ячейка в строке №" & r + 1 & " столбца «" & sh.Cells(1, c) & "» содержит ОШИБКУ!", vbCritical, "Таблица на листе «" & sh.Name & "» ": Exit Function
If Len(arr(r, c)) = 0 Then sh.Select: MsgBox "Ячейка в строке №" & r + 1 & " столбца «" & sh.Cells(1, c) & "» ПУСТАЯ!", vbCritical, "Таблица на листе «" & sh.Name & "» ": Exit Function
Next r
Next c
On Error GoTo dupl: c = 4
For r = 1 To UBound(arr, 1)
dic.Add arr(r, c), 0
Next r
FILE_TableCheck_Part = True: Exit Function
dupl: sh.Select: MsgBox "Ключ в строке №" & r + 1 & " столбца «" & sh.Cells(1, c) & "» — ДУБЛЬ!", vbCritical, "Таблица на листе «" & sh.Name & "» "
End Function
'====================================================================================================
Function FILE_TableCheck_Pos() As Boolean
Dim sh As Worksheet, dic As New Dictionary
Dim arr, r&, c&, cc&
Set sh = shPos: If FILE_TableIsEmpty(sh.ListObjects(1), True) Then Exit Function
arr = sh.ListObjects(1).DataBodyRange.Value2
cc = [_posPriceM].Column
For c = 1 To UBound(arr, 2)
If c <> cc Then
For r = 1 To UBound(arr, 1)
If IsError(arr(r, c)) Then sh.Select: MsgBox "Ячейка в строке №" & r + 1 & " столбца «" & sh.Cells(1, c) & "» содержит ОШИБКУ!", vbCritical, "Таблица на листе «" & sh.Name & "» ": Exit Function
If Len(arr(r, c)) = 0 Then sh.Select: MsgBox "Ячейка в строке №" & r + 1 & " столбца «" & sh.Cells(1, c) & "» ПУСТАЯ!", vbCritical, "Таблица на листе «" & sh.Name & "» ": Exit Function
Next r
End If
Next c
cc = [_posVal].Column
' проверям, чтобы числовые столбцы прощли проверку
For r = 1 To UBound(arr, 1)
c = cc: If arr(r, c) <= 0 Or Abs(arr(r, c) - Format$(arr(r, c), "0.000000")) > 0.0000001 Then GoTo erNum
c = c + 1: If arr(r, c) < 0 Or Abs(arr(r, c) - Format$(arr(r, c), "0.00")) > 0.0000001 Then GoTo erNum
c = c + 1
If Len(arr(r, c)) Then
If arr(r, c) < 0 Or Abs(arr(r, c) - Format$(arr(r, c), "0.000000")) > 0.0000001 Then GoTo erNum
End If
Next r
c = [_posValBal].Column
For r = 1 To UBound(arr, 1)
If arr(r, c) <> 0 Then sh.Select: MsgBox "В строке №" & r + 1 & " ОБЩЕЕ КОЛ-ВО не равно РАСКОНТРАКТОВАННОМУ!", vbCritical, "Таблица на листе «" & sh.Name & "» ": Exit Function
Next r
On Error GoTo dupl: c = [_posKeyGen].Column
For r = 1 To UBound(arr, 1)
dic.Add arr(r, c), 0
Next r
dic.RemoveAll: c = [_posKey].Column
For r = 1 To UBound(arr, 1)
dic.Add arr(r, c), 0
Next r
FILE_TableCheck_Pos = True: Exit Function
erNum: sh.Select: MsgBox "Число в строке №" & r + 1 & " столбца «" & sh.Cells(1, c) & "» не соответствует требованиям!", vbCritical, "Таблица на листе «" & sh.Name & "» ": Exit Function
dupl: sh.Select: MsgBox "Ключ в строке №" & r + 1 & " столбца «" & sh.Cells(1, c) & "» — ДУБЛЬ!", vbCritical, "Таблица на листе «" & sh.Name & "» "
End Function
'====================================================================================================
Function FILE_TableCheck_WO() As Boolean
Dim sh As Worksheet, dic As New Dictionary
Dim arr, r&, c&, cc&, ccc&, flag As Boolean
Set sh = shWO: If FILE_TableIsEmpty(sh.ListObjects(1), True) Then Exit Function
arr = sh.ListObjects(1).DataBodyRange.Value2
For c = 2 To UBound(arr, 2)
If c <> 4 Then
For r = 1 To UBound(arr, 1)
If IsError(arr(r, c)) Then sh.Select: MsgBox "Ячейка в строке №" & r + 1 & " столбца «" & sh.Cells(1, c) & "» содержит ОШИБКУ!", vbCritical, "Таблица на листе «" & sh.Name & "» ": Exit Function
If Len(arr(r, c)) = 0 Then sh.Select: MsgBox "Ячейка в строке №" & r + 1 & " столбца «" & sh.Cells(1, c) & "» ПУСТАЯ!", vbCritical, "Таблица на листе «" & sh.Name & "» ": Exit Function
Next r
End If
Next c
cc = [_WOsend].Column: ccc = [_WOmarket].Column
' проверям, чтобы числовые столбцы прощли проверку
For r = 1 To UBound(arr, 1)
c = cc + 1
If Len(arr(r, c - 1)) Then
If arr(r, c) <> 0 Or arr(r, ccc) <= 0 Then GoTo erNum
Else
If arr(r, c) < 0 Or Abs(arr(r, c) - Format$(arr(r, c), "0.00")) > 0.0000001 Then GoTo erNum
End If
c = cc + 2: If arr(r, c) <= 0 Or Abs(arr(r, c) - Format$(arr(r, c), "0.000000")) > 0.0000001 Then GoTo erNum
Next r
On Error GoTo dupl: c = [_WOkeyGen].Column
For r = 1 To UBound(arr, 1)
dic.Add arr(r, c), 0
Next r
dic.RemoveAll: c = [_WOKey].Column
For r = 1 To UBound(arr, 1)
dic.Add arr(r, c), 0
Next r
On Error GoTo 0
dic.RemoveAll: c = [_WOlayer].Column: cc = [_WOcntr].Column
For r = 1 To UBound(arr, 1)
If arr(r, c) = "ТС" Then ' контролируем однообразность "договора":
If InStr(arr(r, cc), FFF_arrow) Then flag = True ' если "договор" напрямую, то в цепочке с подрядчиком не должно быть стрелки (уровня)
Else
If Left$(arr(r, cc), Len(arr(r, c))) <> arr(r, c) Then flag = True ' если "договор" НЕ напрямую, то это должно быть — НАЧАЛО цепочки с подрядчиком
End If
If flag Then sh.Select: MsgBox "Подрядчику «" & arr(r, cc) & "» присвоена позиция от ДРУГОГО ПЕРВИЧНОГО ДОГОВОРА!", vbCritical, "Таблица на листе «" & sh.Name & "» ": Exit Function
If dic.Exists(arr(r, cc)) Then ' проверяем, чтобы у одного и того же "исполнителя" не было разных "договоров"
If dic(arr(r, cc)) <> arr(r, c) Then sh.Select: MsgBox "Подрядчик «" & arr(r, cc) & "» содержит более ОДНОГО договора!", vbCritical, "Таблица на листе «" & sh.Name & "» ": Exit Function
Else
dic(arr(r, cc)) = arr(r, c) ' добавляем пару ПОДРЯДЧИК - ДОГОВОР
End If
Next r
FILE_TableCheck_WO = True: Exit Function
erNum: sh.Select: MsgBox "Число в строке №" & r + 1 & " столбца «" & sh.Cells(1, c) & "» не соответствует требованиям!", vbCritical, "Таблица на листе «" & sh.Name & "» ": Exit Function
dupl: sh.Select: MsgBox "Ключ в строке №" & r + 1 & " столбца «" & sh.Cells(1, c) & "» — ДУБЛЬ!", vbCritical, "Таблица на листе «" & sh.Name & "» "
End Function
Пробовал и DoEvents и выход по флагам, как костыль — всё без толку Есть идеи?
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Запоминаем время и выходим, если прошло меньше секунды с последнего запуска
Код
Private Sub Workbook_SheetCalculate(ByVal sh As Object)
Dim t!
Static tm!
If Timer - tm < 1 Then tm = Timer: Exit Sub
If Application.CutCopyMode Then Exit Sub
t = Timer
Application.ScreenUpdating = False
Application.EnableEvents = False
If Not FILE_TableFill_All() Then GoTo fin
If FILE_TableCheck_All Then MsgBox "Все таблицы успешно перезаполнены и проверены!", vbInformation, Format$(Timer - t, "0.00 сек")
fin:
tm = Timer
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Мониторинг (см. скрин) выявил, что в процессе работы макросов события нигде не включаются, зато он ещё целых 7 (!!!) раз пытается запустить событие
Из выше описанного следует, что моё утверждение
Цитата
Jack Famous в #1: Application.EnableEvents=True не просто включает обработку событий, но и запускает пересчёт, тем самым образуя цикл
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Jack Famous, Вы проверяете макрос на одном листе изменяя формулу. Скорее всего в исходном файле у вас 7 и более листов. Формулы, которых пересекаются между собой. Т.е. на листе 1 у вас написано А3(Лист1)=А1(Лист1)+А2(Лист1), на листе 2 у вас написано А5(Лист2)=А3(Лист1)+А4(Лист2). Вы меняете значение в формуле на листе 1. У вас происходит пересчёт на листе 1 >> срабатывает макрос на пересчёт в книге. Макрос отрабатывает всё как положено. Но на листе 2 у вас опять идёт пересчёт формулы так как её данные тянутся с листа 1 и макрос снова срабатывает. Таким образом снова запускается макрос на пересчёт в книге, только вызван он листом 2. У вас по ходу таких листов 7.
Мастерство программиста не в том, чтобы писать программы, работающие без ошибок. А в том, чтобы писать программы, работающие при любом количестве ошибок.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Jack Famous, Алексей, делайте расчет диапазонов по вашему плану, а не пересчитывайте всю книгу. Вы же знаете зависимости, значит и последовательность знаете.
БМВ: делайте расчет диапазонов по вашему плану, а не пересчитывайте всю книгу — вы же знаете зависимости
да, но тогда придётся для пересчёта делать кнопки на каждом листе, а я хочу, чтобы пользователь по привычному F9 (на самом деле Alt+2, т.к. пересчёт я всем вынес второй кнопкой на ПБД) всё делал. Просто если раньше это был обычный пересчёт, то теперь к нему добавятся макро-аналоги, но для пользователя ничего не изменится… Иными словами, мне важно именно калькуляцию перехватить и "дополнить" своими действиями. В принципе, костыль пока вполне устраивает
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Дмитрий(The_Prist) Щербаков, ничего не мешает, но у меня и так ручной пересчёт стоит по-умолчанию для всей книги В модуле книги в #1 как раз видно, что при открытии книги он выставляется…
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Alec Perle: А проверить, пересчет какой книги вызвал событие?
а чем это лучше моего костыля?
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Наверное, тем, что не стоит верить тому, что очередное (ненужное) событие произойдет именно меньше, чем через секунду. Ну мало ли, древняя машинка, параллельно еще видео конвертится, да еще своп невовремя... А, может, обработку повесить на событие листа (Worksheet_Calculate) (что, по сути, то же что и предложено)?
Alec Perle: не стоит верить тому, что очередное (ненужное) событие произойдет именно меньше, чем через секунду. Ну мало ли, древняя машинка, параллельно еще видео конвертится, да еще своп невовремя
у меня и всех сотрудников отрабатывает корректно, задержка очень просто настраивается в коде, учёт всяких "мало ли" тут вреден для скорости и удобства — какой смысл мне что-то выдумывать, если все текущие задачи "костыль" прекрасно выполняет?… Я бы внял ещё, если бы предложенный вариант был не костылём, а более логичным, правильным и простым способом достичь нужного эффекта, но ваш вариант таковым не является (или я что-то не понимаю)…
Цитата
Alec Perle: обработку повесить на событие листа (Worksheet_Calculate) (что, по сути, то же что и предложено)?
событие ЛИСТА сработает только для ЛИСТА, а мне нужно, чтобы нужные мои действия выполнялись в результате обычного пересчёта (по F9 например)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄