VBA Bedingte formate auflisten

[schauan]

Hallöchen,

nur mal eine weitere Frage - Hast Du eventuell 64 bit Office installiert?

[schwarzeteufel]

Hallo Schauan,

Ja Ich Habe 64 bit Office

[schauan]

Hallöchen,

Problem bei den AddIns ist, dass sie eventuell nicht für 64 bit ausgelegt sind. Mal sehn, ob ich morgen früh was zusammenschreibe

[schauan]

Hallöchen,

ich habe Dir hier mal einen code angepasst. Da wäre noch die Frage, was Du bei Schrift haben willst. Die Schriftart ist ja fix, aber z.B. Fett oder Kursiv wäre einstellbar. Der Code erzeugt eine neue Mappe und trägt dort die Formatierungen des zuvor aktiven Blattes ein.

Code:

Option Explicit

Function CFSignature(ByRef cf As Variant) As String
'Variablendeklaration
Dim aReturn(1 To 3) As String
'Formatierung wird angewendet auf
aReturn(1) = cf.AppliesTo.Address
'Formatierungstyp
aReturn(2) = FCTypeFromIndex(cf.Type)
On Error Resume Next
  'Formel
  aReturn(3) = cf.Formula1
'Array zu einem String zusammensetzen
CFSignature = Join(aReturn, vbNullString)
End Function

Sub ShowConditionalFormatting_4()
'Variablendeklarationen
Dim cf As Variant
Dim rCell As Range
Dim colFormats As Collection
Dim i As Long
Dim wsOutput As Worksheet
Dim aOutput() As Variant
'Collection initialisieren
Set colFormats = New Collection
'Schleife ueber alle Zellen mit bedingter Formatierung
For Each rCell In ActiveSheet.Cells.SpecialCells(xlCellTypeAllFormatConditions).Cells
  'Schleife ueber alle Bedingungen
  For i = 1 To rCell.FormatConditions.Count
    'Mit den Bedingungen
    With rCell.FormatConditions
      'Fehlerbehandlung zur Vermeidung von Mehrfacheintraegen
      'anhand des mit CFSignature festgelegten Keys
      On Error Resume Next
        'Bedingung (i) der Collection hinzufuegen
        'Hinweis: der Item enthaelt alle moeglichen
        'Einstellungen zu der Bedingung.
        colFormats.Add .Item(i), CFSignature(.Item(i))
      On Error GoTo 0
    'Ende Mit den Bedingungen
    End With
  'Ende Schleife ueber alle Bedingungen
  Next i
'Ende Schleife ueber alle Zellen mit bedingter Formatierung
Next rCell
'Ausgabearray dimensionieren - hier begrenzt auf 7 Felder / Einstellungen
ReDim aOutput(1 To colFormats.Count + 1, 1 To 7)
'neue Datei erstellen und erstes Blatt zuweisen
Set wsOutput = Workbooks.Add.Worksheets(1)
'Spaltenbezeichnungen festlegen
aOutput(1, 1) = "Type": aOutput(1, 2) = "Range"
aOutput(1, 3) = "StopIfTrue": aOutput(1, 4) = "Formual1"
aOutput(1, 5) = "Formual2"
aOutput(1, 6) = "Color"
aOutput(1, 7) = "Font"
'Schleife ueber alle CollectionItems
For i = 1 To colFormats.Count
  'Collection-Item an cf zuweisen
  Set cf = colFormats.Item(i)
  'allgemeine Einstellungen uebernehmen
  aOutput(i + 1, 1) = FCTypeFromIndex(cf.Type)
  aOutput(i + 1, 2) = cf.AppliesTo.Address
  aOutput(i + 1, 3) = cf.StopIfTrue
  'Fehlerbehandlung fuer spezielle Einstellungen
  'die nicht in allen bed. Formaten vorhanden sind
  'Hinweis: Koennte man alternativ anhand des Typs realisieren
  On Error Resume Next
    aOutput(i + 1, 4) = "'" & cf.Formula1
    aOutput(i + 1, 5) = "'" & cf.Formula2
    aOutput(i + 1, 6) = "'" & cf.Interior.Color
    aOutput(i + 1, 7) = "'" & cf.Font.FontStyle
  On Error GoTo 0
'Ende Schleife ueber alle CollectionItems
Next i
'Ausgabe in das Blatt
wsOutput.Range("A1").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput
'Spltenbreite anpassen
wsOutput.UsedRange.EntireColumn.AutoFit
End Sub

Function FCTypeFromIndex(lIndex As Long) As String
'Typen bedingter Formatierungen
Select Case lIndex
  Case 12: FCTypeFromIndex = "Above Average"
  Case 10: FCTypeFromIndex = "Blanks"
  Case 1: FCTypeFromIndex = "Cell Value"
  Case 3: FCTypeFromIndex = "Color Scale"
  Case 4: FCTypeFromIndex = "DataBar"
  Case 16: FCTypeFromIndex = "Errors"
  Case 2: FCTypeFromIndex = "Expression"
  Case 6: FCTypeFromIndex = "Icon Sets"
  Case 14: FCTypeFromIndex = "No Blanks"
  Case 17: FCTypeFromIndex = "No Errors"
  Case 9: FCTypeFromIndex = "Text"
  Case 11: FCTypeFromIndex = "Time Period"
  Case 5: FCTypeFromIndex = "Top 10?"
  Case 8: FCTypeFromIndex = "Unique Values"
  Case Else: FCTypeFromIndex = "Unknown"
End Select
End Function

[schwarzeteufel]

Danke Schauan,

Das funktioniert. Schriftart hätte ich FETT. Wo und was muss ich ändern.

Nochmals vielen Dank.

[schauan]

Hallöchen,
Das ist schon so berücksichtigt

[schwarzeteufel]

OK.

Danke Schauan.