|
Beim erneuten Durchsehen habe ich entdeckt, dass im o.g. Code 2 Zeilen zu viel, daher
Sub altKollegen()
'Quelldaten in Tabelle1
'
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
'vorhanden, sonst erstellen
Set oWst = Sheets("Tmp")
'löschen
oWst.Cells.Clear
With Sheets("Tabelle1") 'ggf. ändern
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
'Set rngCol = rngCol.Offset(1).Resize(rngCol.Rows.Count - 1)
With .UsedRange
.AutoFilter Field:=y, Criteria1:="=1", Operator:=xlAnd
'Sheets("Tabelle1").UsedRange.Columns(1).SpecialCells(12).Copy
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
'temp. Protokoll
Sheets.Add
ActiveSheet.Name = "Tmp"
Resume
Case Else
End Select
Set oWst = Nothing
Application.ScreenUpdating = True
End Sub
|