Thema Datum  Von Nutzer Rating
Antwort
01.11.2023 13:48:33 Bernd
NotSolved
02.11.2023 21:37:01 xlKing
NotSolved
03.11.2023 08:59:19 Bernd
NotSolved
03.11.2023 16:46:09 ralf_b
NotSolved
06.11.2023 09:22:14 Bernd
NotSolved
06.11.2023 17:48:00 ralf_b
NotSolved
Rot  Bedingte Formatierung aus einem kompletten Sheet auslesen und einfügen.
 02.11.2023 22:47:39 ralf_b
NotSolved
07.11.2023 09:59:53 Bernd
NotSolved
07.11.2023 22:52:38 ralf_b
NotSolved

Ansicht des Beitrags:
Von:
ralf_b		 Datum:
02.11.2023 22:47:39		 Views:
435		 Rating:
     
Antwort:
  Ja
Thema:
Bedingte Formatierung aus einem kompletten Sheet auslesen und einfügen.

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.

 

?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
' ----------------------------------------------------------------
' 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.

?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
' ----------------------------------------------------------------
' 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

 

Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:
WYSIWYG-Editor, ctl00_Content_editor1



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
01.11.2023 13:48:33 Bernd
NotSolved
02.11.2023 21:37:01 xlKing
NotSolved
03.11.2023 08:59:19 Bernd
NotSolved
03.11.2023 16:46:09 ralf_b
NotSolved
06.11.2023 09:22:14 Bernd
NotSolved
06.11.2023 17:48:00 ralf_b
NotSolved
Rot  Bedingte Formatierung aus einem kompletten Sheet auslesen und einfügen.
 02.11.2023 22:47:39 ralf_b
NotSolved
07.11.2023 09:59:53 Bernd
NotSolved
07.11.2023 22:52:38 ralf_b
NotSolved