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