Performance problem mit active cell makro
alex
ich habe leider ein kleines performance problem mit einem makro
und zwar habe ich eine datei wo aus 4 spalten (4.quartale) das max datum über den active cell befehl ermittelt wird und in 4 zellen eines anderen worksheets übertragen wird.
das geht auch relativ fix bei kleinen anlagen mit 50 spalten.
jetzt habe ich gerade eine anlagen mit über 700 zeilen bearbeitet und er braucht fast 1 minute um die datei zu speichern (das makro wird beim speichern ausgelöst).
ist ja auch klar warum er muß ja schließlich 4 mal 700 zeilen durcharbeiten und den max. datumswert herausfinden. wenn ich das makro deaktiviere speichert er ganz normal in 1-2 sec.
gibt es eine möglichkeit das makro umzuschreiben oder irgendwie anders die performance zu erhohen?
speicherzeiten bis 10 sec sind ja vertretbar, aber 1 min. das kann ich niemanden antun.
danke für eure hilfe vorab schonmal
beispieldatei folgt.
code:
Sub quartalswartung_schreiben()
Dim t As String
Dim s As String
Application.ScreenUpdating = False
'1 quatal
If Application.WorksheetFunction.CountA(Sheets("KT").Range("F18:F2000")) = 0 Then
Tabelle5.Range("A1") = ""
Else
Tabelle1.Select
[B18].Select
While ActiveCell ""
If ActiveCell.Offset(0, 4) = Application.WorksheetFunction.Max(Columns(6)) Then
Tabelle5.Range("A1") = ActiveCell.Offset(0, 4) & " " & ActiveCell.Offset(0, 5)
End If
ActiveCell.Offset(1, 0).Select
Wend
End If
'2 quatal
If Application.WorksheetFunction.CountA(Sheets("KT").Range("j18:j2000")) = 0 Then
Tabelle5.Range("B1") = ""
Else
Tabelle1.Select
[B18].Select
While ActiveCell ""
If ActiveCell.Offset(0, 8) = Application.WorksheetFunction.Max(Columns(10)) Then
Tabelle5.Range("B1") = ActiveCell.Offset(0, 8) & " " & ActiveCell.Offset(0, 9)
End If
ActiveCell.Offset(1, 0).Select
Wend
End If
'3 quatal
If Application.WorksheetFunction.CountA(Sheets("KT").Range("n18:n2000")) = 0 Then
Tabelle5.Range("c1") = ""
Else
Tabelle1.Select
[B18].Select
While ActiveCell ""
If ActiveCell.Offset(0, 12) = Application.WorksheetFunction.Max(Columns(14)) Then
Tabelle5.Range("C1") = ActiveCell.Offset(0, 12) & " " & ActiveCell.Offset(0, 13)
End If
ActiveCell.Offset(1, 0).Select
Wend
End If
'4 quatal
If Application.WorksheetFunction.CountA(Sheets("KT").Range("r18:r2000")) = 0 Then
Tabelle5.Range("d1") = ""
Else
Tabelle1.Select
[B18].Select
While ActiveCell ""
If ActiveCell.Offset(0, 16) = Application.WorksheetFunction.Max(Columns(18)) Then
Tabelle5.Range("D1") = ActiveCell.Offset(0, 16) & " " & ActiveCell.Offset(0, 17)
End If
ActiveCell.Offset(1, 0).Select
Wend
End If
t = ThisWorkbook.Sheets("kt").Cells(11, 3) 'setzt den _
objektnamen
s = ThisWorkbook.Sheets("kt").Cells(3, 5) 'setzt den _
typ
On Error Resume Next 'ü _
berspringt fehler
Workbooks("wartung.xls").Activate 'Wartung. _
xls soll aktiviert werden- setzt fehlerwert auf true (1)
strPath = ThisWorkbook.Path 'legt den _
pfad der mappe mit diesem makro in strPath fest
ChDrive Left(strPath, 2) 'wechselt _
das laufwerk. left(strPath,2) gibt die ersten zwei Zeichen von links aus dem Text der in strPath steht zurück (Z:).
ChDir strPath 'wechselt _
das verzeichnis --- der pfad ist jetzt eingeloggt und workbook.open("../wartung.xls") kann ausgeführt werden
If Err 0 Then 'schleife _
mit bedingung (fehler wert ungleich 0) und folge
Workbooks.Open ("../../wartung.xls") 'öffnet _
im darüber liegenden verzeichnis wartung.xls
With Workbooks("wartung.xls").Sheets("OM").Range("b1:d1000") 'beschreibt den bereich _
mit dem gearbeitet wird
Set c = .Find(t, LookAT:=xlWhole) 'setzt _
variable c auf die position des gefunden wertes t
If c.Offset(0, 2) s Then
With Range(c.Offset(0, 2), c.Offset(1, 2)) ' _
beschreibt den bereich in dem gearbeitet wird in dem fall 2 spalten weiter und 2 spalten weiter und eine zeile tiefer als variable c
Set d = .Find(s, LookAT:=xlWhole) 'setzt _
variable d auf die position des gefunden wertes s
d.Offset(0, 3) = ThisWorkbook.Sheets("werte").Cells(1, 1)
d.Offset(0, 4) = ThisWorkbook.Sheets("werte").Cells(1, 2)
d.Offset(0, 5) = ThisWorkbook.Sheets("werte").Cells(1, 3)
d.Offset(0, 6) = ThisWorkbook.Sheets("werte").Cells(1, 4)
End With
Else
c.Offset(0, 5) = ThisWorkbook.Sheets("werte").Cells(1, 1)
c.Offset(0, 6) = ThisWorkbook.Sheets("werte").Cells(1, 2)
c.Offset(0, 7) = ThisWorkbook.Sheets("werte").Cells(1, 3)
c.Offset(0, 8) = ThisWorkbook.Sheets("werte").Cells(1, 4)
End If
End With
Workbooks("Wartung.xls").Save
Windows("Wartung.xls").Close
Err.Clear 'setzt den fehler wert auf 0
Else
With Workbooks("wartung.xls").Sheets("OM").Range("b1:d1000") 'beschreibt den bereich _
mit dem gearbeitet wird
Set c = .Find(t, LookAT:=xlWhole) 'setzt variable c auf die position _
des gefunden wertes t
If c.Offset(0, 2) s Then
With Range(c.Offset(0, 2), c.Offset(1, 2)) ' _
beschreibt den bereich in dem gearbeitet wird in dem fall 2 spalten weiter und 2 spalten weiter und eine zeile tiefer als variable c
Set d = .Find(s, LookAT:=xlWhole) 'setzt _
variable d auf die position des gefunden wertes s
d.Offset(0, 3) = ThisWorkbook.Sheets("werte").Cells(1, 1)
d.Offset(0, 4) = ThisWorkbook.Sheets("werte").Cells(1, 2)
d.Offset(0, 5) = ThisWorkbook.Sheets("werte").Cells(1, 3)
d.Offset(0, 6) = ThisWorkbook.Sheets("werte").Cells(1, 4)
End With
Else
c.Offset(0, 5) = ThisWorkbook.Sheets("werte").Cells(1, 1)
c.Offset(0, 6) = ThisWorkbook.Sheets("werte").Cells(1, 2)
c.Offset(0, 7) = ThisWorkbook.Sheets("werte").Cells(1, 3)
c.Offset(0, 8) = ThisWorkbook.Sheets("werte").Cells(1, 4)
End If
End With
End If
ThisWorkbook.Activate 'aktiviert die mappe mit diesem makro
Application.ScreenUpdating = True 'lässt den bildschirm weiter laufen
Exit Sub
End Sub