Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1368to1372
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Macroausführung dauert sehr lange. Optimierung!

Macroausführung dauert sehr lange. Optimierung!
18.07.2014 10:05:55
Nils
Hi zusammen,
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!

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Macroausführung dauert sehr lange. Optimierung!
18.07.2014 10:34:34
Martin
Hallo Nils,
teste mal:
Sub Extract()
Dim lz As Integer, TR As Integer
Dim WBPath As String, CurrentBook As String, Book As String
With Application
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With
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
'Copy Worksheet
With Workbooks(CurrentBook)
.Activate
Sheets("Template").Visible = True
Sheets("Template").Copy Before:=Workbooks(Book).Sheets(1)
.Sheets("Template").Visible = False
End With
'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
Range("G2:G100").Sort Key1:=Range("G2"), Order1:=xlAscending, Header:=xlNo
End With
With Application
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Viele Grüße
Martin

Anzeige
AW: Macroausführung dauert sehr lange. Optimierung!
21.07.2014 18:53:26
Nils
.Calculation = xlCalculationManual
Danke dafür! Hat natürlich sehr viel gebracht :)

AW: Macroausführung dauert sehr lange. Optimierung!
18.07.2014 11:18:13
Daniel
Hi
Man sollte vermeiden, in Excel Zellen einzeln zu bearbeiten.
Günstiger ist immer, möglichst viele Zellen als Block gemeinsam in einem Arbeitsschritt zu bearbeiten.
probiere mal, ob das schneller ist
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
Dim rngCopy As Range
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(Book).Sheets(1).Name = "Extract " & Format(Date, "mm-dd-yyyy")
'Copy Worksheet
With Workbooks(CurrentBook).Sheets("Template")
.Visible = True
.Copy Before:=Workbooks(Book).Sheets(1)
.Visible = False
End With
'Definition of source format
With Workbooks(CurrentBook).Sheets("Changes")
With .Cells.SpecialCells(xlCellTypeLastCell)
With Range(.Offset(5 - .Row, 1), .Offset(0, 1))
.FormulaR1C1 = "=If(Or(RC17(Today()+14),"""",1)"
.Formula = .Value
If WorksheetFunction.Sum(.Cells) > 0 Then
Set rngCopy = .SpecialCells(xlCellTypeConstants, 1)
.ClearContents
End If
End With
End With
If Not rngCopy Is Nothing Then
With Workbooks(Book).Sheets(1)
.Cells(TR, 1).Resize(.Cells.Count).Value = "Carrier"
.Cells(TR, 3).Resize(.Cells.Count).Value = "Carrier Management"
End With
Set rngCopy = rngCopy.EntireRow
Intersect(.Columns(1), rngCopy).Copy: Workbooks(Book).Sheets(1).Cells(TR, 2). _
PasteSpecial xlPasteValues
Intersect(.Columns(2), rngCopy).Copy: Workbooks(Book).Sheets(1).Cells(TR, 4). _
PasteSpecial xlPasteValues
Intersect(.Columns(5), rngCopy).Copy: Workbooks(Book).Sheets(1).Cells(TR, 6). _
PasteSpecial xlPasteValues
Intersect(.Columns(6), rngCopy).Copy: Workbooks(Book).Sheets(1).Cells(TR, 5). _
PasteSpecial xlPasteValues
Intersect(.Columns(7), rngCopy).Copy: Workbooks(Book).Sheets(1).Cells(TR, 9). _
PasteSpecial xlPasteValues
Intersect(.Columns(17), rngCopy).Copy: Workbooks(Book).Sheets(1).Cells(TR, 7). _
PasteSpecial xlPasteValues
Intersect(.Columns(17), rngCopy).Copy: Workbooks(Book).Sheets(1).Cells(TR, 10). _
PasteSpecial xlPasteValues
Intersect(.Columns(19), rngCopy).Copy: Workbooks(Book).Sheets(1).Cells(TR, 8). _
PasteSpecial xlPasteValues
Intersect(.Columns(19), rngCopy).Copy: Workbooks(Book).Sheets(1).Cells(TR, 11). _
PasteSpecial xlPasteValues
End If
End With
Application.CutCopyMode = False
End Sub
getestet habe ich es nicht, weil ich keine passende datei zur verfügung habe.
Gruß Daniel
Anzeige

53 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige