Sub UF_ALL_Print()
Dim i As Long
Dim oSh_Log As Worksheet
Dim oWb As Workbook
Dim oSh As Worksheet
Dim rr As Range
Dim rCell As Range
Dim ItemFormatConditions As FormatCondition
Call EventsChange(False)
'создать лист для записи формул условного форматирования
Set oSh_Log = fun_ShAdd("List_FormatConditions", True)
i = 1
With oSh_Log
.Cells(i, 1).Value = "Лист"
.Cells(i, 2).Value = "Ячейка"
.Cells(i, 3).Value = "Формула"
End With
On Error Resume Next
Set oWb = ActiveWorkbook
For Each oSh In oWb.Sheets
Debug.Print oSh.Name, "---------------------------------------------------------"
' ActiveCell.SpecialCells(xlCellTypeAllFormatConditions).Select
' ActiveCell.SpecialCells(xlCellTypeAllValidation).Select
Set rr = oSh.UsedRange.SpecialCells(xlCellTypeAllFormatConditions)
If Not rr Is Nothing Then
oSh.Select
rr.Select
For Each rCell In rr
For Each ItemFormatConditions In rCell.FormatConditions
If InStr(ItemFormatConditions.Formula1, "[") > 0 Then
i = i + 1
Debug.Print oSh.Name, rCell.Address, ItemFormatConditions.Formula1 ' : "=$M$10" : String
oSh_Log.Cells(i, 1).Value = oSh.Name
oSh_Log.Cells(i, 2).Value = rCell.Address
oSh_Log.Cells(i, 3).Value = "'" & ItemFormatConditions.Formula1
' ItemFormatConditions.Delete
End If
Next 'ItemFormatConditions
Next 'rCell
Set rr = Nothing
End If
Next 'oSh
oSh_Log.Select
Call EventsChange(True)
End Sub
Sub UF_Err_Delete()
Dim rr As Range
Dim rCell As Range
Dim ItemFormatConditions As FormatCondition
Set rCell = ActiveCell
' Set rCell = ActiveSheet.UsedRange.SpecialCells(xlCellTypeAllFormatConditions)
' ActiveCell.SpecialCells(xlCellTypeAllFormatConditions).Select
On Error Resume Next
Set rr = ActiveSheet.UsedRange.SpecialCells(xlCellTypeAllFormatConditions)
For Each rCell In rr
For Each ItemFormatConditions In rCell.FormatConditions
If InStr(ItemFormatConditions.Formula1, "[") > 0 Then
Debug.Print rCell.Address, ItemFormatConditions.Formula1 ' : "=$M$10" : String
ItemFormatConditions.Delete
End If
Next
Next
End Sub
'============================================================
' ##### включает или отключает события
'
Sub Восстановить()
Call EventsChange(False)
Call EventsChange(True)
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub EventsChange(Value As Boolean)
With Application
' .Calculation = xlCalculationAutomatic
.ScreenUpdating = Value
.ShowWindowsInTaskbar = Value
.DisplayAlerts = Value
.EnableEvents = Value
If Value Then
.Calculation = xlCalculationAutomatic
Else: .Calculation = xlCalculationManual
End If
End With
End Sub
'============================================================
'======================================================================================
'#####удаление/создание листа по имени
'
'--------------------------------------------------------------------------------------
Function fun_ShAdd(ByVal strShName As String, _
ByVal blnRecreate As Boolean) As Worksheet
Dim strShNameAct As String
strShNameAct = ActiveSheet.Name
If blnRecreate Then 'пересоздание листа сначала удаляем
Call ShDelete(strShName) 'удалить лист
End If
If fun_ShExists(ThisWorkbook, strShName) Then 'если лист существует
Set fun_ShAdd = ThisWorkbook.Sheets(strShName)
'очистка листа
FnShAdd.Cells.Clear
Else
Set fun_ShAdd = ThisWorkbook.Sheets.Add 'Before:=Sheets(1)
With fun_ShAdd
.Move Before:=Sheets(1)
.Name = strShName
End With
End If
Windows(ThisWorkbook.Name).Activate
Sheets(strShNameAct).Select
End Function
'--------------------------------------------------------------------------------------
Sub ShDelete(ByVal ShName As String)
On Error Resume Next
With Application
.DisplayAlerts = False
With .ThisWorkbook
For Each Sh In .Sheets
If Sh.Name = ShName Then Sh.Delete
Next Sh
End With
.DisplayAlerts = True
End With
End Sub
'--------------------------------------------------------------------------------------
'проверка существования листа
Function fun_ShExists(ByVal oWb As Workbook, _
ByVal strShName As String) As Boolean
With oWb
For Each Sh In .Sheets
If Sh.Name = strShName Then fun_ShExists = True: Exit Function
Next Sh
End With
End Function
'======================================================================================
