Kommentare aus Zwischenablage entfernen

[schauan]

Hallöchen,

ja, da ist immer noch keine Rückmeldung da
Ich hab trotzdem mal mein Brainstorming umgesetzt
Der Code kommt in DieseArbeitsmappe. Min. zwei Probleme dürfte es geben. Zum einen funktioniert es nicht oder nicht 100%ig bei Kopie aus einer anderen Mappe oder Anwendung, zum anderen könnte es Probleme mit größeren Datenmengen geben. Mein Schleifenzähler ist auf Integer dimensioniert, aber auch das könnte schon zuviel des Guten sein … Na ja, und weil aller guter Dinge 3 sind könnte es sein, dass die Ereignismakros gewohnte andere Aktionen stören

Code:

Option Explicit
'Variablendeklaration
Public rng1 As Range, rng2 As Range
Public arrComment

Private Sub Workbook_Open()
'Selectierten Bereich ermitteln
Set rng1 = Selection
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
'Makro laeuft nicht bei Workbook_Open
'Kommentare und Bereiche ermitteln
ReadComment
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim rngZellen As Range, iCnt%
'Bei Fehler weiter
On Error Resume Next
'Schleife ueber alle Zellen in denen eingefuegt wurde
For Each rngZellen In Target
  'Schleifenzaehler hochsetzen
  iCnt = iCnt + 1
  'eventuellen Kommentar loeschen
  .Comment.Delete
  'alten Kommentar enfuegen
  rngZellen.AddComment arrComment(iCnt)
  'oder so
  'If Not IsEmpty(arrComment(iCnt)) Is Nothing Then rngZellen.AddComment arrComment(iCnt)
'Ende Schleife ueber alle Zellen in denen eingefuegt wurde
Next
'Selectierten Bereich ermitteln
'Nach dem Einfuegen st ggf. ein groesserer Bereich entsprechend Quelldaten selectiert
Set rng1 = Selection
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
'Kommentare und Bereiche ermitteln
ReadComment
End Sub

Private Sub ReadComment()
Dim rngZellen As Range
'Selection merken
Set rng2 = Selection
'Wenn keine vorhergehende Selction vorhanden ist, dann die aktuelle nehmen
'sollte eigentlich nicht passieren, ausser, wenn im Debug-Modus beendet wurde
If rng1 Is Nothing Then Set rng1 = rng2
'Wenn die Bereiche unterschiedlich gross sind, dann
If rng1.Cells.Count <> rng2.Cells.Count Then
  'zweiten Bereich anpassen
  Set rng2 = rng2.Resize(rngZellen.Rows.Count, rngZellen.Columns.Count)
'Ende Wenn die Bereiche unterschiedlich gross sind, dann
End If
'ersten bereich neu setzen
Set rng1 = Selection
'Array anhand Zielzellenzahl redimensionieren
ReDim arrComment(1 To rng2.Cells.Count)
'Schleife ueber alle Zellen
For Each rngZellen In rng2.Cells
  'Schleifenzaehler hochsetzen
  iCnt = iCnt + 1
  'Kommentar uebernehmen, wenn vorhanden
  If Not rngZellen.Comment Is Nothing Then arrComment(iCnt) = rngZellen.Comment.Text
'Ende Schleife ueber alle Zellen
Next
End Sub