Option
Explicit
Dim
oWbk
As
Workbook
Dim
aTypen()
As
Variant
Dim
xcnt
As
Long
Dim
bFirst
As
Boolean
Sub
AbstractTypes()
Dim
oWsh
As
Worksheet
Dim
rFilter
As
Range
Set
oWbk = ThisWorkbook
Set
oWsh = oWbk.Sheets(
"Rollentypen"
)
With
oWsh
If
.Cells(2, 1).Value =
""
Then
ErrorBreak oWsh.Name,
"Cells(2, 1).Value ="
aTypen = Range(.Cells(2, 1), .Cells(.Rows.Count, 1).
End
(xlUp))
End
With
Set
oWsh = oWbk.Sheets(
"Bedarfe"
)
bFirst =
False
With
oWsh
With
.UsedRange
For
xcnt = LBound(aTypen)
To
UBound(aTypen)
.AutoFilter
.AutoFilter Field:=5, Criteria1:=aTypen(xcnt, 1)
Set
rFilter = .SpecialCells(12)
WriteBack rFilter, rFilter.Areas.Count
Next
xcnt
End
With
End
With
End
Sub
Sub
WriteBack(rFound
As
Range, ac
As
Long
)
Dim
oWsh
As
Worksheet
Dim
uc
As
Range
Dim
x
As
Long
Set
oWsh = oWbk.Sheets(
"Auswertung"
)
With
oWsh
If
Not
bFirst
Then
Set
uc = .UsedRange
Set
uc = uc.Offset(1, 0).Resize(uc.Rows.Count - 1, uc.Columns.Count)
uc.ClearContents
Set
uc = .Cells(1, 1)
bFirst =
True
Else
Set
uc = .Cells(1, 1).
End
(xlDown)
End
If
If
ac > 1
Then
For
x = 2
To
rFound.Areas.Count
Set
uc = uc.Offset(1)
uc.Value = rFound.Areas(x).Cells(5).Value
uc.Offset(0, 1).Value = rFound.Areas(x).Cells(7).Value
uc.Offset(0, 2).Value = rFound.Areas(x).Cells(3).Value
Next
x
Else
Set
uc = uc.Offset(1)
uc.Value = aTypen(xcnt, 1)
End
If
End
With
End
Sub
Sub
ErrorBreak(sMsg
As
String
, sCode
As
String
)
Call
MsgBox(sMsg &
" "
& sCode, vbCritical,
"Error in"
)
End
End
Sub