Hallo,

okidoki, die Hitzewelle ist vorbei, also hier mal ein zweiter Ansatz, Du hattest jetzt ja idealerweise Daten mitgeliefert, da kann man nach einem zweiten Schlüsselwort ('Instrument') suchen...

Option Explicit

Public Sub test()
  Const LAST_COLUMN As Long = 9  '// Tabellen-Block-Breite SourceSheet
  Const SEARCH_STRING As String = "Objekt" '// Suchtext Tabellenname
  Const SEARCH_STRING_2 As String = "Instrument" '// Suchtext Tabellenende
  Dim wksSheet As Worksheet
  Dim objStartCell As Range, objLastCell As Range
  Dim strChars As String
  Dim lngIndex As Long, lngHeaderColor As Long
  lngHeaderColor = RGB(210, 210, 210) '// Header-Color
  strChars = ": 0" '// Objekt-Bez. SourceSheet
  On Error GoTo Sub_Exit
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  For Each wksSheet In ThisWorkbook.Worksheets
     With wksSheet
         If .Name Like SEARCH_STRING & "*" Then Call .Delete
     End With
  Next
  Application.DisplayAlerts = True
  Set wksSheet = ThisWorkbook.Worksheets("ET-Utility Report")
    Do
        lngIndex = lngIndex + 1
        If lngIndex > 9 Then strChars = ": "
              With ThisWorkbook.Worksheets("ET-Utility Report")
                  Set objStartCell = .Cells.Find( _
                      What:=SEARCH_STRING & strChars & lngIndex, LookIn:=xlValues, _
                        LookAt:=xlWhole, MatchCase:=False)
                  If Not objStartCell Is Nothing Then
                    If lngIndex > 8 Then strChars = ": "
                    Set objLastCell = .Cells.Find( _
                      What:=SEARCH_STRING & strChars & lngIndex + 1, LookIn:=xlValues, _
                        LookAt:=xlWhole, MatchCase:=False)
                    If Not objLastCell Is Nothing Then
                      With objStartCell
                            If .Offset(-1, 0).Interior.Color <> lngHeaderColor Then
                              Set objStartCell = .Offset(-2, 0)
                            Else
                              Set objStartCell = .Offset(-1, 0)
                            End If
                      End With
                      Set objLastCell = .Range(objLastCell, objLastCell.Offset(-10, 0)).Find( _
                         What:=SEARCH_STRING_2, LookIn:=xlValues, _
                         LookAt:=xlWhole, SearchDirection:=xlPrevious, MatchCase:=False)
                    Else
                      Set objLastCell = .Range(objStartCell, .Cells(.Cells(.Rows.Count, 2).End(xlUp).Row, _
                         objStartCell.Column)).Find(What:=SEARCH_STRING_2, LookIn:=xlValues, _
                           LookAt:=xlWhole, SearchDirection:=xlPrevious, MatchCase:=False)
                      If Not objLastCell Is Nothing Then
                         Set objStartCell = objStartCell.Offset(-1, 0)
                      Else
                         Call MsgBox("Der Suchwert ist nicht vorhanden....", vbExclamation)
                      End If
                    End If
                      Set wksSheet = ThisWorkbook.Worksheets.Add(After:=wksSheet)
                      With wksSheet
                            .Name = SEARCH_STRING & " " & lngIndex
                            .Columns("B:I").ColumnWidth = 8.88
                            .Columns("J").ColumnWidth = 0.92
                      End With
                      Call .Range(objStartCell, .Cells(objLastCell.Row, LAST_COLUMN + 1)).Copy( _
                          Destination:=wksSheet.Cells(2, 2))
                      Set objLastCell = Nothing
                  End If
              End With
    Loop Until objStartCell Is Nothing
    If lngIndex = 1 Then Call MsgBox("Der Suchwert ist nicht vorhanden....", vbExclamation)
    Call MsgBox("Es wurden " & lngIndex - 1 & " Objekt-Blätter erstellt.", vbExclamation)
Sub_Exit:
    If Err.Number <> 0 Then Call MsgBox("Error: " & _
        Err.Number & " " & Err.Description)
    Set wksSheet = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Gruß,