Option Explicit
Sub BorderColorInMappeErsetzen()
'Für alle benutzten Zellen in der Arbeitsmappe :
'Ersetzen der Rahmenfarbe bei vorhandenem Rahmen
'entsprechend der Konstante c_ColorindexFuerAlleRahmen
'Farbe kann entsprechend der Farbtafel auf Werte 1-56 gesetzt werden
'(siehe Sub DemonstrateColorIndex)
Const c_ColorindexForReplace = 5 '5 entspricht blau
'Indexe für Borders()
'5=xlDiagonalDown, 6=xlDiagonalUp, 7=xlEdgeLeft, 8=xlEdgeTop
'9=xlEdgeBottom, 10=xlEdgeBottom, 11=xlInsideVertical, 12=xlInsideHorizontal
'Linien-Staerke Weight-Konstanten (long):
'0=xlNone, 1=xlHairline, 2=xlThin,-4138=xlMedium, 4=xlThick
'Linien-Stil LineStyle-Konstanten (long):
'1=xlContinuous, -4115=xlDash, 4=xlDashDot, 5=xlDashDotDot
'-4118=xlDot, -4119=xlDouble, 13=xlSlantDashDot, -4142=xlLineStyleNone
'für den Wert 11, der beim Auslesen auch vorkommt, gibt es kein Definition
'.Creator = &h5843454c , long =1480803660 entspr. XCEL
'.Farbindex ColorIndex-Konstanten:
'-4105=xlColorIndexAutomatic,-4142=xlColorIndexNone
'und Farbtafel (siehe Sub DemonstrateColorIndex)
'Border.Color = RGB( , , ) nicht benutzt
Dim ws As Worksheet
Dim c As Integer, r As Integer, i As Integer
Dim long_Linienstaerke As Long, long_Linienstil As Long, long_Creator As Long
Dim int_ColorIndex As Integer
Dim long_Color As Long
Application.ScreenUpdating = False 'Bildschirm-Aktuallisierung ausschalten
'Für alle Blaetter in der aktiven Mappe
For Each ws In Worksheets
ws.Activate
'Für alle benutzten Zellen
For r = 1 To ws.Cells.SpecialCells(xlCellTypeLastCell).Row
For c = 1 To ws.Cells.SpecialCells(xlCellTypeLastCell).Column
For i = 5 To 12 'für alle Border-Indexe
With ws.Cells(r, c).Borders(i)
long_Linienstil = .LineStyle
'Ist eine Rahmen vorhanden ?
If ( _
(long_Linienstil = xlContinuous) Or _
(long_Linienstil = xlDash) Or _
(long_Linienstil = xlDashDot) Or _
(long_Linienstil = xlDashDotDot) Or _
(long_Linienstil = xlDot) Or _
(long_Linienstil = xlDouble) Or _
(long_Linienstil = xlSlantDashDot) _
) Then
.ColorIndex = c_ColorindexForReplace
End If
End With
Next
Next
Next
Next
Worksheets(1).Activate: Worksheets(1).Cells(1, 1).Select
Application.ScreenUpdating = True 'Bildschirm-Aktuallisierung einschalten
End Sub
'--------------------------------------------------------------------------
Sub DemonstrateColorIndex()
'Darstellung der 56 ColorIndex-Farben
Dim i As Integer, m As Integer, i_ColorIndex As Integer
Workbooks.Add
For i = 0 To 5
For m = 1 To 10
i_ColorIndex = i * 10 + m
With ActiveSheet.Cells(m, i + 1)
.Value = i_ColorIndex
.Interior.ColorIndex = i_ColorIndex
.HorizontalAlignment = xlCenter
End With
If i_ColorIndex >= 56 Then Exit Sub
Next
Next
End Sub
