Makro beschleunigen
25.01.2004 08:44:12
Rolf St.
Ich habe mir Dank eurer Hilfe folgendes Makro zusammengebaut!
Gibt es eine Möglichkeit das Makro zu 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
Vielen Dank für eure Hilfe!
Tschüß
Rolf