29.12.2020, 09:57
Seiten: 1 2
29.12.2020, 10:02
Hallo Schauan,
Ja Ich Habe 64 bit Office
Ja Ich Habe 64 bit Office
29.12.2020, 20:18
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
Problem bei den AddIns ist, dass sie eventuell nicht für 64 bit ausgelegt sind. Mal sehn, ob ich morgen früh was zusammenschreibe
30.12.2020, 08:26
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.
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 Function30.12.2020, 11:54
Danke Schauan,
Das funktioniert. Schriftart hätte ich FETT. Wo und was muss ich ändern.
Nochmals vielen Dank.
Das funktioniert. Schriftart hätte ich FETT. Wo und was muss ich ändern.
Nochmals vielen Dank.
30.12.2020, 12:41
Hallöchen,
Das ist schon so berücksichtigt
Das ist schon so berücksichtigt
30.12.2020, 12:44
OK.
Danke Schauan.
Danke Schauan.
Seiten: 1 2