Kommentare: Farbpalette

[TxbyFmjy]

Verbesserungsvorschläge sind willkommen.

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 Sub

Nachfolgender 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