ich möchte gerne Kommentare auslesen bzw gleiche Kommentare zählen lassen.
Siehe Bsp-Mappe https://www.herber.de/bbs/user/24011.xls
Vielleicht hat jemand ne Lösung.
Gruß und danke vorab
Tom
Sub ListComments()
Dim c As Comment, cmt As Comments
Set cmt = ActiveSheet.Comments
For Each c In cmt
Debug.Print c.Text
Next
End Sub
'Ausagbe
Dim AusgabeBereich As Range
Dim Ausgabe()
Dim Z As Long
Dim C As Long
Set AusgabeBereich = Range("I1:K1")
Ausgabe = Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Transpose(AusgabeBereich))
Z = AusgabeBereich.Row
C = AusgabeBereich.Column
For i = 1 To UBound(Kommentare) - 1
'Überschriften
Cells(Z, C + i - 1) = Application.WorksheetFunction.Substitute(Kommentare(i + 1), Chr(10), "")
For k = 1 To UBound(Namen)
'Anzahl
Cells(Z + k, C + i - 1) = Namen(k, i + 1)
Next k, i
Set AusgabeBereich = Nothing
Private Sub KommentareZählen()
Dim Kommentar As Comment 'Kommentar
Dim Kommentare() As String 'Feld, das alle bisher gefundenen Kommentare enthält
Dim Namen() 'Namen(1,1)=Name1
'Namen(2,1)=Name2
'Namen(1,2)=Anzahl der gefundenen 1. Kommentare von Name1
'Namen(1,3)=Anzahl der gefundenen 2. Kommentare von Name1
Dim Zeile As Long 'Index des Namens
Dim KommText As String 'Text des Kommentars
Dim i As Integer 'Zählvariabele
Dim k As Integer 'Zählvariabele
Dim Bereich As Range 'Bereich, in dem die Namen stehen
Set Bereich = Range("A2:A7") 'kriegts Du angepasst
Namen = Bereich
ReDim Kommentare(1)
For Each Kommentar In ActiveSheet.Comments
Zeile = Kommentar.Parent.Row - Bereich.Row + 1 'Index ermitteln
KommText = Kommentar.Text
For i = 1 To UBound(Namen, 2) 'Prüfen, ob Kommentar schon vorhanden?
If Kommentare(i) = KommText Then Exit For
Next i
If i > UBound(Namen, 2) Then 'wenn Kommentar nicht gefunden
ReDim Preserve Kommentare(UBound(Kommentare) + 1) 'Felder erweitern
ReDim Preserve Namen(1 To UBound(Namen, 1), 1 To UBound(Kommentare))
Kommentare(UBound(Kommentare)) = KommText 'neuen Kommentar merken
End If
Namen(Zeile, i) = Namen(Zeile, i) + 1 'Anzahl Kommentar dieses Namens um 1 erhöhen
Next Kommentar
'Ausagbe
For i = 1 To UBound(Kommentare) - 1
For k = 1 To UBound(Namen)
MsgBox Namen(k, 1) & " hat " & Kommentare(i + 1) & ": " & Namen(k, i + 1)
Next k, i
Set Bereich = Nothing
End Sub