Sub Inhaltskopie()
  Dim Meldung As Long
  Dim Suchen As Variant
  Dim n%, x%, xZelle%, yZelle%
  Dim Bereich$, text$, Adresse$(), Akte$()
  Dim Startzeile As Long
  Dim wksAktiv As Worksheet
  Startzeile = ActiveCell.Row
  Set wksAktiv = ActiveSheet
  Bereich = "D20:Ende"

start:

  'Suchbegriff eingeben
  Suchen = InputBox("Suchgegriff eingeben." & vbCrLf & _
  "ENTER ohne Wert = Abbruch", "Filminfos suchen & kopieren", ActiveCell.Value)
  If Suchen = "" Then Exit Sub

  ' letzte Zelle im Bereich ermitteln
  With ActiveSheet.Range(Bereich)
  xZelle = .Columns(.Columns.Count).Column
  yZelle = .Rows(.Rows.Count).Row
  End With

  ' Eigentlicher Suchvorgang
  x = 1
  With wksAktiv.Range(Bereich)
    Set c = .Find(Suchen, After:=Cells(yZelle, xZelle), LookIn:=xlValues)
    If Not c Is Nothing Then
      ErsteAdresse = c.Address
      Do
        ReDim Preserve Adresse(x)
        Adresse(x) = c.Address(RowAbsolute:=False, ColumnAbsolute:=False)

        Set c = .FindNext(c)
        x = x + 1
      Loop While Not c Is Nothing And c.Address <> ErsteAdresse
    End If
  End With

  ' Anzeige der Suchergebnisse
  text = vbCrLf

  ' Die Anzahl der gefundenen Werte ist (x - 1), wenn keiner
  ' gefunden wurde dann ist x = 1

  Select Case x
    Case 1
      If MsgBox("Nichts gefunden. Suche abbrechen?", vbYesNo, "Keine Treffer") = vbNo Then GoTo start
    Case 2
    merkdir = ActiveCell.Address
     Range(Adresse(1)).Select
     If ActiveCell.Address = merkdir Then
      If MsgBox("Nichts gefunden. Suche abbrechen?", vbYesNo, "Keine Treffer") = vbNo Then GoTo start
     Else
      If MsgBox("   Diese Filminfo übernehmen?", vbYesNo, "1 Treffer") = vbYes Then
        Call Kopieren(wks:=wksAktiv, ZeileStart:=Startzeile, Zeile:=Range(Adresse(1)).Row)
      End If
     End If
    Case Else
      merkdir = ActiveCell.Address
      For n = 1 To x - 1
              Range(Adresse(n)).Select
       If Not ActiveCell.Address = merkdir Then
         ActiveWindow.ScrollRow = ActiveWindow.ActiveCell.Row
         ActiveWindow.SmallScroll Up:=2
        Meldung = MsgBox("Suchergebnis " & n & _
        " von " & (x - 1) & _
        ". Diese Filminfo übernehmen?", vbYesNoCancel, "Mehrere Treffer")
        If Meldung = vbNo Then
          'do nothing, weiter suchen
        ElseIf Meldung = vbYes Then
          'Daten in Startzeile kopieren
          Call Kopieren(wks:=wksAktiv, ZeileStart:=Startzeile, Zeile:=Range(Adresse(n)).Row)
          Exit For
        ElseIf Meldung = vbCancel Then
          Exit For
        End If
       End If
      Next n
  End Select
  Cells(Startzeile + 1, 4).Select
  ActiveWindow.ScrollRow = ActiveWindow.ActiveCell.Row
  ActiveWindow.SmallScroll Up:=2

End Sub

Private Sub Kopieren(wks As Worksheet, ZeileStart&, Zeile&)
  'Die Kopierfunktion soll folgendes machen:
  With wks
  '1.) Kopiere Kommentar von Dxx nach D-Startzeile
    .Cells(Zeile, 4).Copy
    .Cells(ZeileStart&, 4).PasteSpecial Paste:=xlPasteComments
  '2.) Kopiere Zelle Exx nach (E-Startzeile)
    .Cells(Zeile, 2).Copy Destination:=.Cells(ZeileStart&, 2)
    .Cells(Zeile, 5).Copy Destination:=.Cells(ZeileStart&, 5)
  '3.) Kopiere Zellen Zxx-ACxx nach Startzeile
    .Range(.Cells(Zeile, 26), .Cells(Zeile, 29)).Copy Destination:=.Cells(ZeileStart, 26)
    Application.CutCopyMode = False
  End With
End Sub