MyTetra Share
Делитесь знаниями!
Удаление условного форматирования
Время создания: 21.01.2021 11:51
Текстовые метки: Links, Связи, Names, UF, Condition, условное форматирование
Раздел: !Закладки - VBA - Excel - Names
Запись: xintrea/mytetra_db_adgaver_new/master/base/1611219094meyb68o5b6/text.html на raw.githubusercontent.com

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

'======================================================================================


 
MyTetra Share v.0.59
Яндекс индекс цитирования