AW: Kommentare aus mehreren Zellinhalten
27.06.2020 08:57:02
fcs
Hallo Andreas,
hier 2 Makros
LG
Franz
Sub Make_Comments()
Dim rngZelle As Range, objComment As Comment, bolComment As Boolean
Dim sText As String, zei As Long, zeiL As Long, spa As Long
Dim wks As Worksheet
Dim msgPrompt As String, msgButtons As Long, msgTitle As String
Const zei_T As Long = 4 'Zeile mit Spaltentiteln
On Error GoTo Fehler
Set wks = ActiveSheet
msgPrompt = "Kommentare im Blatt """ & wks.Name & """ in Spalte M erstellen/aktualisieren?"
msgTitle = "Kommentare aus Zellinhalten erstellen"
msgButtons = vbQuestion + vbYesNo
If MsgBox(msgPrompt, msgButtons, msgTitle) = vbNo Then Exit Sub
With wks
zeiL = .Cells.Find(what:="*", after:=.Cells(1, 1), LookIn:=xlFormulas, lookat:=xlWhole, _
_
searchorder:=xlByRows, searchdirection:=xlPrevious).Row
For zei = zei_T + 1 To zeiL
Set rngZelle = .Cells(zei, 13) 'Zelle in Spalte M
Set objComment = rngZelle.Comment
'Prüfen, ob Inhalt in einer der Zellen
bolComment = Application.WorksheetFunction.CountA(.Cells(zei, 12), _
.Range(.Cells(zei, 15), .Cells(zei, 21))) > 0
If bolComment Then
sText = .Cells(zei_T, 12).Text & ": " & .Cells(zei, 12).Text
For spa = 15 To 21
sText = sText & vbLf & .Cells(zei_T, spa).Text & ": " _
& .Cells(zei, spa).Text
Next spa
If objComment Is Nothing Then
Set objComment = rngZelle.AddComment(sText)
With objComment.Shape
.Height = 110
.Width = 150
With .TextFrame.Characters.Font
.Name = "Calibri"
.Size = 10
.Color = RGB(0, 0, 255)
End With
With .Fill
.ForeColor.RGB = RGB(255, 255, 204)
End With
End With
Else
objComment.Text (sText)
End If
Else
'kein Kommentar wenn alle Zellen leer
If Not objComment Is Nothing Then objComment.Delete
End If
Next zei
End With
Fehler:
Dim errMsg As String, errTitle As String
With Err
errMsg = "Fehler-Nr.: " & .Number & vbLf & .Description
errTitle = "Fehler Makro: Make_Comments"
Select Case .Number
Case 0 ' Alles OK
Case 91 'Object-Fehler
errMsg = errMsg & vbLf & "Tabellenblatt ist leer - Makro wird abgebrochen"
MsgBox errMsg, vbOKOnly, errTitle
Case Else
MsgBox errMsg, vbOKOnly, errTitle
End Select
End With
End Sub
'Kurzversion
'Kurzversion
Sub Make_Comments_kurz()
Dim sText As String, zei As Long, zeiL As Long, spa As Long
Dim wks As Worksheet
Const zei_T As Long = 4 'Zeile mit Spaltentiteln
Set wks = ActiveSheet
If MsgBox("Kommentare im Blatt """ & wks.Name & """ in Spalte M erstellen/aktualisieren?", _
_
vbQuestion + vbYesNo, "Kommentare aus Zellinhalten erstellen") = vbNo Then Exit Sub
With wks
zeiL = .Cells.Find(what:="*", after:=.Cells(1, 1), LookIn:=xlFormulas, lookat:=xlWhole, _
_
searchorder:=xlByRows, searchdirection:=xlPrevious).Row
For zei = zei_T + 1 To zeiL
sText = .Cells(zei_T, 12).Text & ": " & .Cells(zei, 12).Text
For spa = 15 To 21
sText = sText & vbLf & .Cells(zei_T, spa).Text & ": " & .Cells(zei, spa).Text
Next spa
With .Cells(zei, 13) 'Zelle in Spalte M
If .Comment Is Nothing Then
.AddComment (sText)
With .Comment.Shape
.Height = 110
.Width = 150
End With
Else
.Comment.Text sText
End If
End With
Next zei
End With
End Sub