If Sheets("Bedarfe").Range("E" & j).Value = Rollentyp Then
Rollenanzahl = Sheets("Bedarfe").Range("G" & j).Value
'
' <<< hier
'
Sheets("Auswertung").Select
Sheets("Auswertung").Range("A" & k).Value = Rollentyp
Sheets("Auswertung").Range("B" & k).Value = Rollenanzahl
k = k + 1
Sheets("Bedarfe").Select
'
End If
Next j
'
' >>> nicht!
'
'
Next i
allzu viele Datensätze dürfen es aber nicht sein, bei den Schleifen tickt die Uhr ganz schön lange ;)
alternative wäre:
Option Explicit
Dim oWbk As Workbook
Dim aTypen() As Variant
Dim xcnt As Long
Dim bFirst As Boolean
Sub AbstractTypes()
'
'******************************************************************************
' je Rollentyp
' Bedarfe filtern (zu jedem Typ)
' daraus sichtbare Zeilen
' Benötigtes nach Auswertung schreiben
'******************************************************************************
'
Dim oWsh As Worksheet
'
Dim rFilter As Range
Set oWbk = ThisWorkbook
Set oWsh = oWbk.Sheets("Rollentypen")
'Rollentypenverzeichnis
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
'Bedarfe filtern nach aTypen
Set oWsh = oWbk.Sheets("Bedarfe")
bFirst = False
With oWsh
With .UsedRange
For xcnt = LBound(aTypen) To UBound(aTypen)
.AutoFilter
'nach Typ
.AutoFilter Field:=5, Criteria1:=aTypen(xcnt, 1)
'sichtbare
Set rFilter = .SpecialCells(12)
'Treffer ?
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")
'schreiben
With oWsh
If Not bFirst Then
'Neuanfang
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
'fortsetzen
Set uc = .Cells(1, 1).End(xlDown)
End If
'zurückschreiben
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
|