Sub altKollegen()
Dim oWst As Worksheet
Dim rngUsed As Range, rngCol As Range, rngTo As Range, rngTo2 As Range
Dim y As Long
Application.ScreenUpdating = False
On Error GoTo errorh
Set oWst = Sheets("Tmp")
oWst.Cells.Clear
With Sheets("Tabelle1")
Set rngUsed = .UsedRange
For y = 2 To rngUsed.Columns.Count
Set rngCol = rngUsed.Columns(y)
If y = 2 Then
Set rngTo = oWst.Cells(1, 1)
Else
Set rngTo = oWst.Cells(oWst.Rows.Count, 2).End(xlUp).Offset(1, -1)
End If
rngTo.Value = rngCol.Cells(1).Value
With .UsedRange
.AutoFilter Field:=y, Criteria1:="=1", Operator:=xlAnd
Set rngTo2 = Sheets("Tabelle1").UsedRange.Columns(1)
Set rngTo2 = rngTo2.Offset(1).Resize(rngTo2.Rows.Count)
rngTo2.SpecialCells(12).Copy
rngTo.Offset(, 1).PasteSpecial xlPasteValues
.AutoFilter
End With
Next y
End With
On Error GoTo 0
errorh:
Select Case Err.Number
Case 0
oWst.Activate
Case 9
Sheets.Add
ActiveSheet.Name = "Tmp"
Resume
Case Else
End Select
Set oWst = Nothing
Application.ScreenUpdating = True
End Sub