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
	  
     |