Ich würde es allgemein so angehen:
Option Explicit
Public Sub Test()
Dim rngS As Excel.Range
Dim rngT As Excel.Range
Set rngS = Range("A2") 'Beispiel
Set rngT = Range("C2") 'Beispiel, hier wird der Kommentar gesetzt
'# Vorbereitung: Kommentar
rngT.Value = "Kommentar"
Call rngT.EntireColumn.AutoFit 'Spaltenbreite anpassen
'# Vorbereitung: Teil-Ausdruck (aus einer Zelle stammend)
'Teil-Ausdruck für den Kommentar setzen
rngS.Value = "Ey, hallo Du da!"
'Ausdruck 'hallo' formatieren
rngS.Characters(5, 6).Font.Italic = True
'Ausdruck 'Du' formatieren
rngS.Characters(11, 2).Font.Bold = True
rngS.Characters(11, 2).Font.Underline = xlUnderlineStyleSingle
Call rngS.EntireColumn.AutoFit 'Spaltenbreite anpassen
'# Zellen-Kommentar löschen, falls bereits einer vorhanden ist
If Not rngT.Comment Is Nothing _
Then Call rngT.Comment.Delete
'# jetzt gehts los, Kommentar zusammenbauen
Call CommentAppend(rngT, "Überschrift", Bold:=True)
Call CommentAppend(rngT, vbNewLine & Space$(3))
Call CommentAppend(rngT, "* Punkt-1", Italic:=True)
Call CommentAppend(rngT, vbNewLine & Space$(3))
Call CommentAppend(rngT, "* Punkt-2", Bold:=True)
Call CommentAppend(rngT, vbNewLine & Space$(3))
Call CommentAppend(rngT, "* Punkt-3", Italic:=True, Underline:=xlUnderlineStyleSingle)
Call CommentAppend(rngT, vbNewLine & Space$(3))
Call CommentAppend(rngT, "* Punkt-4", Bold:=True, Italic:=True, Underline:=xlUnderlineStyleDouble)
Call CommentAppend(rngT, vbNewLine & vbNewLine)
Call CommentAppend(rngT, rngS) '<- als Quelle dient hier ein Zellenbereich und dessen Formatierung
' ODER z.B.
' ' * ohne Formatierung 'Fett' zu berücksichtigen
' Call CommentAppend(rngT, rngS, Bold:=False)
' ' * ohne Formatierung 'Fett' und 'Unterschtrichen' zu berücksichtigen
' Call CommentAppend(rngT, rngS, Bold:=False, Underline:=False)
'# Kommentar noch in seiner Größe passend dimensionieren
rngT.Comment.Shape.TextFrame.AutoSize = True
End Sub
'////////////////////////////////////////////////////////////////
'// die "tolle" Hilfsfunktion
Public Sub CommentAppend( _
Target As Excel.Range, _
Source As Variant, _
Optional ByVal Bold As Variant, _
Optional ByVal Italic As Variant, _
Optional ByVal Underline As Variant _
)
Const ERR_INVALID_ARG As Long = 5
Dim rngSrc As Excel.Range
Dim lngLenPrev As Long
If IsObject(Source) Then
If Source Is Nothing Then
Call Err.Raise(ERR_INVALID_ARG)
ElseIf TypeOf Source Is Excel.Range Then
If Source.Cells.Count = 1 Then
If IsMissing(Bold) Then Bold = True 'Default: ja, übernehmen
If IsMissing(Italic) Then Italic = True 'Default: ja, übernehmen
If IsMissing(Underline) Then Underline = True 'Default: ja, übernehmen
Set rngSrc = Source
Call CommentAppendR(Target, rngSrc, CBool(Bold), CBool(Italic), CBool(Underline))
Else
Call Err.Raise(ERR_INVALID_ARG)
End If
Else
Call Err.Raise(ERR_INVALID_ARG)
End If
Else 'einfach formatierten Text hinzufügen
If Target.Comment Is Nothing Then
Call Target.AddComment(Text:=CStr(Source))
Else
lngLenPrev = Len(Target.Comment.Text)
Call Target.Comment.Text(Text:=CStr(Source), Start:=lngLenPrev + 1)
End If
With Target.Comment.Shape.TextFrame.Characters(lngLenPrev + 1, Len(CStr(Source))).Font
.Underline = IIf(IsMissing(Underline), xlUnderlineStyleNone, CLng(Underline))
.Italic = IIf(IsMissing(Italic), False, CBool(Italic))
.Bold = IIf(IsMissing(Bold), False, CBool(Bold))
End With
End If
End Sub
'////////////////////////////////////////////////////////////////
'// Hilfsfunktion (Range-Version)
'// !! diese nicht selbst aufrufen !! - wird über "CommentAppend" ausgeführt
Private Sub CommentAppendR( _
Target As Excel.Range, _
Source As Excel.Range, _
ApplyBold As Boolean, _
ApplyItalic As Boolean, _
ApplyUnderline As Boolean _
)
Dim objCharSrc As Excel.Characters
Dim lngLenPrev As Long
Dim i As Long
If Target.Comment Is Nothing Then
Call Target.AddComment(Text:=Source.Text)
Else
lngLenPrev = Len(Target.Comment.Text)
Call Target.Comment.Text(Text:=Source.Text, Start:=lngLenPrev + 1)
End If
With Target.Comment.Shape.TextFrame
'nachfolgender Ablauf ist noch optimierbar
For i = 1 To Source.Characters.Count
Set objCharSrc = Source.Characters(i, 1)
With .Characters(lngLenPrev + i, 1).Font
.Underline = IIf(ApplyUnderline, objCharSrc.Font.Underline, xlUnderlineStyleNone)
.Italic = IIf(ApplyItalic, objCharSrc.Font.Italic, False)
.Bold = IIf(ApplyBold, objCharSrc.Font.Bold, False)
End With
Next
End With
End Sub
|