Macroausführung dauert sehr lange. Optimierung!
18.07.2014 10:05:55
Nils
ich habe eine Tabelle und möchte bestimmte Zellen in ein neu erstelltes Excel Sheet kopieren. Das klappt in der Regel ganz gut, dauert aber sehr lange und scheint eine größere Hürde für meinen neuen PC zu sein und leider "verschluckt" sich das Macro dann hin und wieder und Zellen werden auf einmal falsch kopiert. Habt ihr eine Idee, wie ich diesen Code optimieren könnte?
Sub Extract()
Application.DisplayAlerts = False
Dim lz As Integer
Dim TR As Integer
Dim WBPath As String
Dim CurrentBook As String
Dim Book As String
lz = Sheets("Changes").Cells(Rows.Count, 1).End(xlUp).Row
WBPath = ThisWorkbook.Path & "\" & ThisWorkbook.Name
TR = 2
'Duplicate Template
CurrentBook = ActiveWorkbook.Name
Workbooks.Add
Book = ActiveWorkbook.Name
Workbooks(CurrentBook).Activate
'Copy Worksheet
Sheets("Template").Visible = True
Sheets("Template").Copy Before:=Workbooks(Book).Sheets(1)
Workbooks(CurrentBook).Sheets("Template").Visible = False
'Definition of source format
With Workbooks(CurrentBook).Sheets("Changes")
For S = 5 To lz
If .Cells(S, 17) Date + 14 Then GoTo nx:
Chgid = .Cells(S, 1)
ChgIss = .Cells(S, 2)
Location = .Cells(S, 6)
Subject = .Cells(S, 5)
TargStart = .Cells(S, 17)
TargFinDate = .Cells(S, 19)
ServImp = .Cells(S, 7)
'Definition of target format
Workbooks(Book).Activate
Sheets(1).Name = "Extract " & Format(Date, "mm-dd-yyyy")
With ActiveSheet
.Cells(TR, 1) = "Carrier"
.Cells(TR, 2) = Chgid
.Cells(TR, 3) = "Carrier Management"
.Cells(TR, 4) = ChgIss
.Cells(TR, 5) = Location
.Cells(TR, 6) = Subject
.Cells(TR, 7) = TargStart
.Cells(TR, 8) = TargFinDate
.Cells(TR, 9) = ServImp
.Cells(TR, 10) = TargStart
.Cells(TR, 11) = TargFinDate
End With
TR = TR + 1
nx: Next S
ActiveSheet.Range("G2:G100").Sort _
Key1:=ActiveSheet.Range("G2"), Order1:=xlAscending, _
Header:=xlNo
End With
Application.DisplayAlerts = True
End Sub
Vielen Dank für eure Hilfe!