Option Explicit
Public Sub test()
Const LAST_COLUMN As Long = 9
Const SEARCH_STRING As String = "Objekt"
Const SEARCH_STRING_2 As String = "Instrument"
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)
strChars = ": 0"
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