Makro beschleunigen

Sub Uebertragen()
Dim rng As Range
Dim zelle As Range
Dim lRow As Long
Dim zell As Range
Application.ScreenUpdating = False
Sheets("bitburger").Activate
Range(Cells(2, 1), Cells(1000, 11)).ClearContents
Sheets("Eingabe").Activate
With Worksheets("bitburger")
lRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
Range("F2:F1000").Copy .Cells(lRow, 1)
End With
With Worksheets("bitburger")
lRow = .Cells(Rows.Count, 2).End(xlUp).Row + 1
Range("E2:E1000").Copy .Cells(lRow, 2)
End With
With Worksheets("bitburger")
lRow = .Cells(Rows.Count, 3).End(xlUp).Row + 1
Range("J2:J1000").Copy .Cells(lRow, 3)
End With
With Worksheets("bitburger")
lRow = .Cells(Rows.Count, 4).End(xlUp).Row + 1
Range("I2:I1000").Copy .Cells(lRow, 4)
End With
With Worksheets("bitburger")
lRow = .Cells(Rows.Count, 11).End(xlUp).Row + 1
Range("G2:G1000").Copy .Cells(lRow, 11)
End With
With Worksheets("bitburger")
lRow = .Cells(Rows.Count, 7).End(xlUp).Row + 1
Range("B2:B1000").Copy .Cells(lRow, 7)
End With
With Worksheets("bitburger")
lRow = .Cells(Rows.Count, 8).End(xlUp).Row + 1
Range("A2:A1000").Copy .Cells(lRow, 8)
End With
With Worksheets("bitburger")
lRow = .Cells(Rows.Count, 9).End(xlUp).Row + 1
Range("D2:D1000").Copy .Cells(lRow, 9)
End With
With Worksheets("bitburger")
lRow = .Cells(Rows.Count, 10).End(xlUp).Row + 1
Range("L2:L1000").Copy .Cells(lRow, 10)
End With
Application.CutCopyMode = False
Sheets("bitburger").Select
Range("A1").Select
Dim i As Integer
For i = 2 To 1000
Cells(i, 5).Value = Cells(i, 11).Value & Cells(i, 10).Value
Next i
Sheets("bitburger").Select
Range("A1").Select
Set rng = Worksheets("bitburger").Range("E2:E1000")
rng.Offset(0, 1).Clear
For Each zelle In rng
If zelle <> "" Then
zelle.Offset(0, 1) = WorksheetFunction.CountIf(Range("E2:E" & zelle.Row), zelle.Value)
End If
Next
Range("I2:I1000").Select
Selection.NumberFormat = "h:mm:ss"
Range("A1").Select
For Each zell In Range("G2:G1000")
zell = Left(zell, 1)
Next zell
Range("F2:I1000").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("E:E").Select
Selection.EntireColumn.Hidden = True
Columns("J:K").Select
Selection.EntireColumn.Hidden = True
Range("A1").Select
Application.ScreenUpdating = False
End Sub