12.06.2021, 15:32
Verbesserungsvorschläge sind willkommen.
Hallo,
mit nachfolgendem Code lässt sich die Füllfarbe der Kommentare ändern:
Nachfolgender Code erstellt eine Tabelle mit der Farbpalette für die Auswahl einer Füllfarbe für die Kommentare:
Hallo,
mit nachfolgendem Code lässt sich die Füllfarbe der Kommentare ändern:
Code:
Sub Füllfarbe_Kommentare()
Dim myrangeC As Excel.Range
Dim myCell As Excel.Range
Dim col As Long
Dim i As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For col = 1 To ActiveSheet.UsedRange.Columns.Count
Set myrangeC = Intersect(ActiveSheet.UsedRange, Columns(col), _
Cells.SpecialCells(xlCellTypeComments))
If myrangeC Is Nothing Then GoTo nxtCol
For Each myCell In myrangeC
On Error GoTo LabelC
mycell.Comment.Shape.Fill.ForeColor.schemecolor = 26
'mycell.Comment.Shape.Fill.ForeColor.schemecolor = 43
'mycell.Comment.Shape.Fill.ForeColor.schemecolor = 35
'mycell.Comment.Shape.Fill.ForeColor.schemecolor = 40
'mycell.Comment.Shape.Fill.ForeColor.schemecolor = 41
LabelB:
On Error GoTo 0
Next myCell
nxtCol:
Next col
LabelC:
If col > ActiveSheet.UsedRange.Columns.Count Then GoTo Ende
i = i + 1
If i = 1 And Err > 0 Then Debug.Print "Anzahl Zellen", "Addressbereich Verbundene Zellen", "Error Nummer", "Error Beschreibung"
If Err > 0 Then Debug.Print " "; i, " "; myCell.MergeArea.Address, " "; Err.Number, ""; Err.Description
Resume LabelB
Ende:
Set myrangeC = Nothing
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
On Error GoTo 0
End SubNachfolgender Code erstellt eine Tabelle mit der Farbpalette für die Auswahl einer Füllfarbe für die Kommentare:
Code:
Sub SchemeColorUebersicht_FüllfarbenKommentare()
' Erstellt in einer neuen Arbeitsmappe eine Übersicht der
' SchemeColor-Nummern mit zugehöriger Farbe.
' Uwe Küstner 20061212
Dim iColor As Byte, iX As Byte, iY As Byte, iZ As Byte
Dim lngRed As Long, lngGreen As Long, lngBlue As Long
Dim rngB As Range
Application.ScreenUpdating = False
Workbooks.Add xlWBATWorksheet
ActiveSheet.Name = "SchemeColors"
For iY = 2 To 31 Step 3
For iX = 2 To 25 Step 3
iColor = iColor + 1
Set rngB = Range(Cells(iY, iX), Cells(iY + 2, iX + 2))
With ActiveSheet.Shapes.AddShape(msoShapeBevel, rngB.Left, rngB.Top, _
rngB.Width, rngB.Height)
With .Fill
.ForeColor.schemecolor = iColor
lngRed = (.ForeColor And vbRed)
lngGreen = (.ForeColor And vbGreen) \ &H100
lngBlue = (.ForeColor And vbBlue) \ &H10000
End With
iZ = _
(((0.3 * lngRed) + (0.59 * lngGreen) + (0.11 * lngBlue)) < 150) * -255
.Line.Visible = msoFalse
With .TextFrame
.Characters.Text = "SchemeColor: " & iColor & vbLf & _
"RGB(" & lngRed & ", " & lngGreen & ", " & lngBlue & ")" & _
vbLf & "Hex: &H" & _
Format(Hex(lngRed), "00") & _
Format(Hex(lngGreen), "00") & _
Format(Hex(lngBlue), "00") & ""
.Characters.Font.Name = "Tahoma"
.Characters.Font.Size = 7
.Characters.Font.Color = RGB(iZ, iZ, iZ)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
Next iX
Next iY
Cells.ColumnWidth = 4.5
Cells.RowHeight = 13
Rows(1).RowHeight = 6
Application.ScreenUpdating = True
End Sub