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