Clever-Excel-Forum

Sub Makro2()

  Dim rngF As Range, rngS As Range

  Dim strS As String

  With Columns(3)

    Set rngS = .Find(What:="TÜV", After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt _

        :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _

        False, SearchFormat:=False)

    Set rngF = Rows(1)

    If Not rngS Is Nothing Then

      strS = rngS.Address

      Do

        Set rngF = Application.Union(rngF, rngS.EntireRow)

        Set rngS = .FindNext(rngS)

        If rngS Is Nothing Then Exit Do

      Loop Until rngS.Address = strS

    End If

  End With

  Set rngS = ActiveCell

  Sheets("Tabelle2").Cells.Delete

  rngF.Select

  Selection.Copy Sheets("Tabelle2").Cells(1)

  rngS.Select

End Sub