als array
27.08.2015 16:53:20
Michael
Hi zusammen,
ich habe echt keinen Schimmer, was die Tabelle tun soll.
Optimiert habe ich sie trotzdem mittels Array, und zum direkten Vergleich mit dem Originalcode habe ich je Timer-Abfragen zu Beginn und Ende des Codes:
Option Explicit
Sub FormelInZellen1_optiTest()
Dim aSt As Variant, aEr As Variant
Dim i&, j&, imax&, jmax&
Dim t(0 To 1) As Double
t(0) = Timer
imax = Worksheets("Start").Cells(Rows.Count, 1).End(xlUp).Row
jmax = Worksheets("Start").Cells(2, Columns.Count).End(xlToLeft).Column
aSt = Worksheets("Start").Range("A1", Cells(imax, jmax))
aEr = Worksheets("Ergebnis").Range("A1", Worksheets("Ergebnis").Cells(imax, jmax))
' Application.ScreenUpdating = False
For i = 3 To imax
If aEr(i, 3) > 2 Then
aSt(i, 3) = "Start"
Else: aSt(i, 3) = 1
End If
For j = 4 To jmax
If aEr(i, j) + aEr(i, j - 1) >= 5 Then
aSt(i, j) = "1Start"
Else
If aEr(i, j) > 2 Then
If Right(aSt(i, j - 1), 2) = "rt" Then
aSt(i, j) = "1Start"
Else: aSt(i, j) = aSt(i, j - 1) + 1 & "Start"
End If
Else
If Right(aSt(i, j - 1), 2) = "rt" Then
aSt(i, j) = 1
Else: aSt(i, j) = aSt(i, j - 1) + 1
End If
End If
End If
Next j
Next i
Worksheets("Start").Range("A1", Worksheets("Start").Cells(imax, jmax)) = aSt
' Application.ScreenUpdating = True
t(1) = Timer
MsgBox (t(1) - t(0)) * 1000
End Sub
Sub FormelInZellen1_orig()
Dim wsStart, wsErg As Worksheet
Dim rng As Range
Dim i, j As Long
Dim t(0 To 1) As Double
t(0) = Timer
Set wsStart = Worksheets("Start")
Set wsErg = Worksheets("Ergebnis")
Application.ScreenUpdating = False
With wsStart
For i = 3 To .Cells(Rows.Count, 1).End(xlUp).Row
If wsErg.Cells(i, "C") > 2 Then
.Cells(i, "C") = "Start"
Else: .Cells(i, "C") = 1
End If
For j = 4 To .Cells(2, Columns.Count).End(xlToLeft).Column
If wsErg.Cells(i, j).Value + wsErg.Cells(i, j - 1).Value >= 5 Then
.Cells(i, j).Value = "1Start"
Else
If wsErg.Cells(i, j) > 2 Then
If Right(.Cells(i, j - 1), 2) = "rt" Then
.Cells(i, j).Value = "1Start"
Else: .Cells(i, j).Value = .Cells(i, j - 1).Value + 1 & "Start"
End If
Else
If Right(.Cells(i, j - 1), 2) = "rt" Then
.Cells(i, j).Value = 1
Else: .Cells(i, j).Value = .Cells(i, j - 1).Value + 1
End If
End If
End If
Next j
Next i
End With
Application.ScreenUpdating = True
t(1) = Timer
MsgBox (t(1) - t(0)) * 1000
End Sub
Der Code läuft in ca. 2/9 vom Original, bringt also 7/9 Einsparung.
Schöne Grüße,
Michael
P.S.: Der optimierte Code läuft mit *auskommentiertem* Screenupdating aus/ein etwa doppelt so schnell wie mit - verstehe ich zwar nicht, ist aber auch nicht schlecht.