Servus knox,
vielleicht etwas ausführlicher :
comments – bedient sich eines Shape Object (mit beschränkten Eigenschaften)
Was locker geht habe ich im Makro aufgezeigt, es bleibt also immer Bastelarbeit
daher noch zu deiner eigentlichen Problemstellung als Denkanstoß :
If Cells(i, 7) = "X" Then
'***********************************
'bereits hier genügt !!
Set rng = ActiveSheet.Cells(i, 7)
'***********************************
'
For k = 6 To rowANLAGEN
If SYSTEMID = Cells(k, 5) Then
'SySerialNo = Cells(k, 6)
'Systemname = Cells(k, 7)
'******************************************
'dim Anweisung ! ? ! nicht vergessen !!
'Dim Arr()
'Dim aa
aa = aa + 1
ReDim Preserve Arr(1 To aa)
Arr(aa) = Cells(k, 6) & " - " & Cells(k, 7)
'******************************************
Exit For
End If
Next k
'erst am Ende der Schleife
'wbk_reform.Activate
'Sheets(1).Activate
'Set rng = ActiveSheet.Cells(i, 7)
'If rng.Comment Is Nothing Then rng.AddComment
'rng.Comment.Text temp & SySerialNo & " - " & Systemname
'temp = temp & SySerialNo & " - " & Systemname & Chr(10)
'rng.Comment.Shape.TextFrame.AutoSize = True
'
am Ende dann
Next i
'**************************************
'jetzt der Kommentar
wbk_reform.Activate
'Sheets(1).Activate
With rng
On Error Resume Next
.Comment.Delete
On Error GoTo 0
.AddComment
'Debug.Print .Comment.Shape.Width, Len(Arr(1)), UBound(Arr)
'Bastelarbeit mit .Width und .Height
'oder auch .TextFrame.Characters - Eigenschaften
'
'erlaubt sind 4 Einträge oder Umbruch
If UBound(Arr) <= 4 Then
For aa = 1 To UBound(Arr)
.Comment.Text Text:=Arr(aa) & Chr(10), Start:=Len(.Comment.Text) + 1
Next aa
Else
.Comment.Shape.Width = .Comment.Shape.Width * 2 'vgl. Bastelarbeit
On Error Resume Next
For aa = 1 To UBound(Arr) Step 2
.Comment.Text Text:=Arr(aa), Start:=Len(.Comment.Text) + 1
.Comment.Text Text:=" | " & Arr(aa + 1) & Chr(10), Start:=Len(.Comment.Text) + 1
Next aa
On Error GoTo 0
End If
End With
End Sub
hm .......... ??
|