|
Aha, da sucht Jemand mein, durch harte Arbeit, Schweiß und Tränen gebasteltetes Makro. Hier werden die Formatconditions auf allen Blättern aufgelistet. Die Blattauswahl kann eingegrenzt werden. Die Auswahl der FC kann auch eingegrenzt werden. Dazu einige Beispiel if bedingungen, die hier auskommentiert wurden.
"bdel" kann auf "true" gesetzt werden, um die vorhandenen FC zu löschen. Bei vielen tausend FC könnte das nützlich sein.
' ----------------------------------------------------------------
' Procedure Name: Listformatcond
' Purpose: Hilfsfunktion zur Auflistung und Bearbeitung vorhanden bedingter Formatierungen
' Procedure Kind: Sub
' Procedure Access: Public
' Author: ralf_b
' Date: 02.03.2021
' ----------------------------------------------------------------
Sub Listformatcond()
Dim ws As Worksheet
Dim x As FormatCondition, bdel As Boolean
Dim i As Long: i = 2
Dim cnt As Integer
Dim wsobjfc As Worksheet
Application.Calculation = xlManual
On Error Resume Next
Set wsobjfc = ActiveWorkbook.Worksheets("objfc")
If Err > 0 Then Set wsobjfc = Worksheets.Add: wsobjfc.Name = "objfc": Err = 0
bdel = False 'Schalter setzten bei Bedarf
wsobjfc.Cells.ClearContents
With wsobjfc 'Überschrift in Blatt "objfc"
.Cells(1, 1).Value = "Sheetname"
.Cells(1, 2).Value = "FC Prio"
.Cells(1, 3).Value = "FC Gültig für"
.Cells(1, 4) = "Interior.Color"
.Cells(1, 5) = "Interior.ColorIndex"
.Cells(1, 6) = "Interior.TintAndShade"
.Cells(1, 7) = "Formel"
End With
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "Checkliste" Then 'Auswahl Sheet
'Debug.Print ws.Name & ": " & ws.Cells.FormatConditions.Count 'info in direktfenster
For cnt = 1 To ws.Cells.FormatConditions.Count 'schleife über Formatconditions
Set x = ws.Cells.FormatConditions(cnt)
'If abfrage bei Bedarf anpassen oder weglassen
'If x.Formula1 Like "*ANZAHL*" Then 'And x.AppliesTo.Address(0, 0) <> "I5:ME677" Then
'If x.Formula1 Like "*ME*ME*" Then
If bdel Then 'Löschen wenn gewollt
x.Delete
cnt = cnt - 1
Else
wsobjfc.Cells(i, 1).Value = ws.Name
wsobjfc.Cells(i, 2).Value = x.Priority
wsobjfc.Cells(i, 3).Value = x.AppliesTo.Address(0, 0)
wsobjfc.Cells(i, 4) = CStr(x.Interior.Color)
wsobjfc.Cells(i, 4).Interior.Color = x.Interior.Color
wsobjfc.Cells(i, 5) = CStr(x.Interior.ColorIndex)
wsobjfc.Cells(i, 5).Interior.ColorIndex = x.Interior.ColorIndex
wsobjfc.Cells(i, 6) = CStr(x.Interior.TintAndShade)
wsobjfc.Cells(i, 6).Interior.TintAndShade = x.Interior.tintandshadse
wsobjfc.Cells(i, 7) = "'" & CStr(x.Formula1)
i = i + 1
End If
'End If 'formula suche
Next cnt
wsobjfc.Columns.AutoFit
End If 'ws.name
Next
Application.Calculation = xlAutomatic
End Sub
hiermit werden doppelte FC gelöscht ,sodas jeweils nur eine jeder Sorte übrig bleibt. Die Auswahl welche FC berücksichtigt wird, wird mit select case getroffen. strText erhält je nach FC Typ ihren Wert und wird in das Dictionary hinzugefügt. Ist strText schon vorhanden wird die betreffende FC gelöscht. das MAkro wird hier abgebrochen wenn If x = 40 Then Exit Do. Also wenn 40 eindeutige FC eingelesen wurden oder wenn die Anzahl der eindeutigen FC = der Gesamtanzahl der FC ist.
' ----------------------------------------------------------------
' Procedure Name: deletedoublefc
' Purpose: löscht doppelte bedingte Formatierungen
' Procedure Kind: Sub
' Procedure Access: Public
' Author: ralf_b
' Date: 02.03.2021
' ----------------------------------------------------------------
Sub deletedoublefc()
'löscht doppelte bedingte Formatierung
Dim i As Long, objfc, x As Long
Dim Mydic, strText As String
Set Mydic = CreateObject("Scripting.Dictionary")
With ActiveWorkbook.ActiveSheet.Cells
i = 1
x = 0
Do While x <> i
i = .FormatConditions.Count
Set objfc = .FormatConditions(i)
Select Case objfc.Type
Case 1, 2, 4, 5, 6, 8, 9, 10, 11, 12, 13, 16, 17 ' xlCellValue 1 Cell value
strText = objfc.Formula1 & " / " & objfc.AppliesTo.Address
' Case 2 'xlExpression 2 Expression
Case 3 'xlColorScale 3 Color scale
strText = "Farbverlauf" & " / " & objfc.AppliesTo.Address
'
' Case 4 'xlDataBar 4 DataBar
' Case 5 'xlTop10 5 Top 10 values
' Case 6 'xlIconSet 6 Icon set
' Case 8 'xlUniqueValues 8 Unique values
' Case 9 'xlTextString 9 Text string
' Case 10 'xlBlanksCondition 10 Blanks condition
' Case 11 'xlTimePeriod 11 Time period
' Case 12 'xlAboveAverageCondition 12 Above average condition
' Case 13 'xlNoBlanksCondition 13 No blanks condition
' Case 16 'xlErrorsCondition 16 Errors condition
' Case 17 'xlNoErrorsCondition 17 No errors condition
Case Else
Debug.Print objfc.Type & " " & objfc.AppliesTo.Address
End Select
If Not Mydic.exists(strText) Then
Mydic.Add (strText), 1
x = x + 1
'Debug.Print "save: " & objfc.AppliesTo.Address & ": " & objfc.Formula1
Else
'Debug.Print "del: " & objfc.AppliesTo.Address & ": " & objfc.Formula1
objfc.Delete
i = i - 1
End If
If x = 40 Then Exit Do
Loop
End With
End Sub
|