Hallo,

besser noch so, wurd erstmal ne On Error-Orgie...arrgh...müsste man nochmal überdenken...

' **********************************************************************
' Modul: Tabelle1 Typ: Klassenmodul des Tabellenblattes
' **********************************************************************

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim objComment As Comment
Dim objCell As Range
Dim lngReturn As Long
On Error Resume Next
If Not Intersect(Target, Cells(1, 3).Resize(10, 1)) Is Nothing Then
   On Error GoTo 0
   With Target
        If .Count = 1 Then
            On Error Resume Next
            lngReturn = .Validation.Type
            On Error GoTo 0
            If lngReturn <> 0 Then
                If .Comment Is Nothing Then
                  Set objComment = .AddComment
                Else
                  Set objComment = .Comment
                End If
                On Error Resume Next
                Set objCell = Tabelle2.Range(Mid$(String:=.Validation.Formula1, Start:=2)).Find( _
                    What:=.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
                On Error GoTo 0
                If Not objCell Is Nothing Then
                  With objCell
                      If Not .Comment Is Nothing Then
                        With .Comment
                            With .Shape
                                objComment.Shape.Width = .Width
                                objComment.Shape.Height = .Height
                            End With
                            Call objComment.Text(Text:=.Text)
                        End With
                      End If
                  End With
                  Set objCell = Nothing
                End If
                Set objComment = Nothing
            End If
        End If
   End With
End If
End Sub

Gruß,