Option Explicit
Sub Test()
'zum Test
Const clng_ZEILE As Long = 2
Const clng_SPALTE As Long = 2
Dim lngRow As Long
'
'
lngRow = 11 'zum Test
'
Call TestKommentar(lngRow, clng_ZEILE, clng_SPALTE)
'
End Sub
Private Sub TestKommentar(ByVal DATENAUS As Long, _
ByVal INZELE As Long, INSPALTE As Long)
'zum Test
Const cstr_QUELLE As String = "Tabelle1"
Const cstr_ZIEL As String = "Tabelle2"
'Kommentar ist mehrspaltig - Breite an Daten anpassen !!!!!
Const clng_Kspalte As Long = 15
Dim wsh1 As Worksheet, wsh2 As Worksheet
Dim rng2 As Range
Dim cmt2 As Comment
Dim shp2 As Object
Dim strText As String
Dim intText As Integer
With ThisWorkbook 'Testdaten
Set wsh1 = .Sheets(cstr_QUELLE)
Set wsh2 = .Sheets(cstr_ZIEL)
End With
Set rng2 = wsh2.Cells(INZELE, INSPALTE)
On Error Resume Next 'ggf. löschen
rng2.Comment.Delete
On Error GoTo 0
Set cmt2 = rng2.AddComment
Set shp2 = cmt2.Shape
With shp2
With .TextFrame
'1. Zeile fett
strText = TestZeile(wsh1.Cells(1, 2), wsh1.Cells(1, 3), clng_Kspalte)
intText = Len(strText)
.Characters(1, intText).Text = strText
.Characters(1, intText).Font.Bold = True
intText = intText + 1
'neue Zeile
.Characters(intText, 1).Text = vbLf
'
'2. Zeile
strText = TestZeile(wsh1.Cells(DATENAUS, 2), wsh1.Cells(DATENAUS, 3), clng_Kspalte)
.Characters(intText, Len(strText)).Text = strText
.Characters(intText, Len(strText)).Font.Bold = False
intText = intText + Len(strText) + 1
'neue Zeile * 2
.Characters(intText, 1).Text = vbLf
intText = intText + 1
.Characters(intText, 1).Text = vbLf
'
'nächste Zeile fett
strText = TestZeile(wsh1.Cells(1, 9), wsh1.Cells(1, 4), clng_Kspalte)
.Characters(intText, Len(strText)).Text = strText
.Characters(intText, Len(strText)).Font.Bold = True
intText = intText + Len(strText) + 1
'neue Zeile
.Characters(intText, 1).Text = vbLf
'
'nächste Datenzeile
strText = TestZeile(wsh1.Cells(DATENAUS, 9) & wsh1.Cells(DATENAUS, 10), wsh1.Cells(DATENAUS, 4), clng_Kspalte)
.Characters(intText, Len(strText)).Text = strText
.Characters(intText, Len(strText)).Font.Bold = False
intText = intText + Len(strText) + 1
'usw.
'
Rem **********************************************************************
Rem am besten den Aufbau nach festen (Spalten) Breiten und Schriftart
Rem **********************************************************************
'
With .Characters.Font 'nichtproportionale Schrift
.Name = "Courier New"
.Size = 10
End With
'
End With
'
.Height = 160 'Maße nach Geschmack oder ausrechnen
.Width = 160
'
End With
End Sub
Private Function TestZeile(ByVal WERT1 As Variant, _
ByVal WERT2 As Variant, ByVal BREITE As Long) As String
Dim strZeile As String
strZeile = Left(CStr(WERT1) & String(BREITE, " "), BREITE)
strZeile = strZeile & Left(CStr(WERT2) & String(BREITE, " "), BREITE)
TestZeile = strZeile
End Function
|