AW: zuviele verschiedene Zellformate
15.10.2003 09:08:50
Hajo_Zi
Hallo Loisl inside
wir hatten vor kurzem bei Spotlight und Zugvogel hat folgendes Makro entwickelt.
Option Explicit
Sub bedFormateZählen()
' von Zugvogel (Mischa)
Dim gefunden As Boolean
Dim i As Long, n As Long, m As Long, lZähler As Integer
Dim tmpStr As String
Dim tmpFormate()
Dim Z As Long
Dim T As Long
lZähler = -1
For i = 1 To Worksheets.Count
For n = 1 To Worksheets(i).UsedRange.Rows.Count
For m = 1 To Worksheets(i).UsedRange.Columns.Count
With Worksheets(i).Cells(n, m)
gefunden = False
For Z = 1 To .Borders.Count
If IsNull(.Borders(Z).LineStyle) = True Then
tmpStr = tmpStr & "000"
Else
With .Borders(Z)
tmpStr = tmpStr & IIf(IsNull(.ColorIndex), "0", .ColorIndex) & _
IIf(IsNull(.LineStyle), "0", .LineStyle) & _
IIf(IsNull(.Weight), "0", .Weight)
End With
End If
Next
tmpStr = tmpStr & .Interior.ColorIndex & _
.Interior.Pattern & _
.Interior.PatternColorIndex & _
.NumberFormat & _
.Font.ColorIndex & _
.Font.Bold & _
.Font.Italic & _
.Font.Underline & _
.Font.FontStyle & _
.Font.Background & _
.Font.Name & _
.Font.OutlineFont & _
.Font.Shadow & _
.Font.Size & _
.Font.Strikethrough & _
.Font.Underline & _
.Font.Subscript & _
.Font.Superscript & _
.HorizontalAlignment & _
.VerticalAlignment & .MergeCells & _
.Orientation & .ShrinkToFit & _
.Height & .IndentLevel & .Locked & _
.Width & .WrapText & .AddIndent
If lZähler <> -1 Then
For T = 0 To lZähler
If tmpFormate(T) = tmpStr Then gefunden = True
Next
End If
If gefunden = False Then
lZähler = lZähler + 1
ReDim Preserve tmpFormate(lZähler)
tmpFormate(lZähler) = tmpStr
End If
End With
tmpStr = ""
Next
Next
Next
MsgBox "Die Arbeitsmappe hat " & lZähler & " abweichende" & IIf(lZähler = 1, "s", "") & " benutzerdef. Zellformat" & IIf(lZähler <> 1, "e", "") & "!" & vbLf & "(Also " & _
lZähler + 1 & IIf((lZähler + 1) = 1, " Format)", " Formate)"), vbInformation
End Sub
Falls Code vorhanden wurde dieser getestet unter Betriebssystem XP Pro und Excel Version XP SBE.
Bitte kein Mail, Probleme sollen im Forum gelöst werden.
Microsoft MVP für Excel
Das Forum lebt auch von den Rückmeldungen.
http://home.media-n.de/ziplies/