Hallo,

...ok ich hab mir erstmal hitzefrei genommen, aber probiers mal hiermit:

Option Explicit

Public Sub test()
  Const MAX_ROW As Long = 1445 '// letzte Zelle letzter Tabellen-Block SourceSheet
  Const LAST_COLUMN As Long = 9  '// Tabellen-Block-Breite SourceSheet
  Const SEARCH_STRING As String = "Objekt" '// Suchtext Tabellenname
  Dim wksSheet As Worksheet
  Dim objTargetCell As Range, objCell As Range
  Dim objStartCell As Range, objLastCell As Range
  Dim strFirstAddress As String, strChars As String
  Dim lngIndex As Long, lngRow As Long, lngCount As Long
  Dim lngHeaderColor As Long
  Dim blnEmpty As Boolean
  lngHeaderColor = RGB(210, 210, 210) '// Header-Color
  strChars = ": 0" '// Objekt-Bez. SourceSheet
  For Each wksSheet In ThisWorkbook.Worksheets
     With wksSheet
            If .Name Like SEARCH_STRING & "*" Then
               Set objTargetCell = .Cells.Find(What:=SEARCH_STRING, _
                  LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
               If objTargetCell Is Nothing Then
                 blnEmpty = True
                 lngIndex = CLng(Mid$(String:=.Name, Start:=Len(SEARCH_STRING) + 1))
                 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
                       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 = objLastCell.Offset(-3, 0)
                         Call .Range(objStartCell, .Cells(objLastCell.Row, LAST_COLUMN + 1)).Copy( _
                               Destination:=wksSheet.Cells(2, 2))
                       Else
                         Set objCell = .Cells.Find( _
                            What:=SEARCH_STRING & strChars & lngIndex, LookIn:=xlValues, _
                              LookAt:=xlWhole, MatchCase:=False)
                         If Not objCell Is Nothing Then
                           strFirstAddress = objCell.Address
                           Do
                               Set objLastCell = objCell
                               Set objCell = .Cells.FindNext(After:=objLastCell)
                           Loop Until objCell.Address = strFirstAddress
                           Set objCell = Nothing
                         End If
                         Set objStartCell = objStartCell.Offset(-1, 0)
                         If objLastCell Is Nothing Then
                           lngRow = objStartCell.Row
                         Else
                           lngRow = objLastCell.Row
                         End If
                         Do
                            lngCount = lngCount + 1
                            If lngCount > 50 Then
                              Set objCell = .Cells(MAX_ROW, 2)
                              Exit Do
                            End If
                         Loop Until fncHasBorders(probjRange:=.Cells(lngRow + lngCount, _
                               objStartCell.Column).Resize(2, LAST_COLUMN))
                         If objCell Is Nothing Then
                            Set objCell = .Cells(lngRow + lngCount + 1, LAST_COLUMN + 1)
                         End If
                         Call .Range(objStartCell, objCell).Copy( _
                               Destination:=wksSheet.Cells(2, 2))
                       End If
                       Set objStartCell = Nothing
                       Set objLastCell = Nothing
                       Set objCell = Nothing
                     Else
                       Call MsgBox("Der Suchwert ist nicht vorhanden....", vbExclamation)
                     End If
                 End With
               Else
                 Set objTargetCell = Nothing
               End If
            End If
     End With
   Next
   If Not blnEmpty Then _
      Call MsgBox("Alle Tabellenblätter sind mit Objekt-Tabellen-Blöcken gefüllt.", vbExclamation)
End Sub

Private Function fncHasBorders(ByRef probjRange As Range) As Boolean
  With probjRange
        fncHasBorders = .Borders(xlEdgeBottom).LineStyle = xlContinuous And _
          .Borders(xlEdgeTop).LineStyle = xlContinuous And _
          .Borders(xlEdgeLeft).LineStyle = xlContinuous And _
          .Borders(xlEdgeRight).LineStyle = xlContinuous And _
          .Borders(xlInsideHorizontal).LineStyle = xlContinuous
  End With
End Function

...ah ja und ich bin von einem einmaligen Kopiervorgang ausgegangen, kann man andernfalls noch anpassen...

Gruß,