Rechnen sehr langsam
kerschl
Heute habe ich ein Problem mit einem an sich sehr einfachen Makro. Nur ist leider die Laufzeit mit knapp 10 Minuten indiskutabel.
Evtl. könnt ihr mir helfen. Hier die Vorgeschichte:
Ich erhalte eine csv-Datei, die ich in Excel einspiele. Anschließend möchte ich mit dem folgenden Makro alle Werte eines Gruppen-Kriteriums aufsummieren. Dazu lese ich in einer Schleife so lange, wie das Kriterium (Spalte D) gleich ist. Erkenne ich einen Gruppenwechsel, füge ich eine Spalte ein und addiere alle Werte darüber in einer Summe auf. Im Anschluß lösche ich die Detailzeilen und übernehme die festen Werte in der Summenzeile (keine Formeln mehr).
Alles ziemlich einfach. Ich denke auch, daß der Makro so schlecht nicht ist. Ich habe Selects vermieden und die Berechnung ausgeschaltet. Dennoch läuft das Programm 10 Minuten und die Datei hat eine Größe von 3 MB. Und das bei nur 537 Datensätzen.
Könnt ihr euch das mal ansehen? Vielleicht überseh ich was...
Sub Gruppe_Opal()
Dim bereich As String
Dim gruppe As String
Dim summe As Range
Dim S1 As Integer
Dim sgroup As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
erster = 3 'ist die erste Zeile mit einem Wert
sgroup = "D" 'Spalte mit den Gruppen-Kriterien
'Liste sortieren nach dem Wert, nach dem gruppiert werden soll
j = Range("A65536").End(xlUp).Row
Rows(erster & ":" & j).Select
bereich = sgroup & erster
Selection.Sort Key1:=Range(bereich), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'Summenzeilen berechnen. Gruppenbegriff sgroup steht in Spalte D (FP-Nr)
gruppe = Cells(erster, sgroup).Value
z = erster
y = 0 'y = die Anzahl der Zeilen mit gleichem Gruppen-Kriterium
Do Until z > j + 2
'Suchen, bis wann die Gruppe gleich bleibt
If Cells(z, sgroup).Value = gruppe Then
y = y + 1
'wenn Gruppenwechsel, dann aufaddieren aller Spalten
Else
'z = aktuelle Zeile der Gruppe, y = Anzahl der Zeilen der Gruppe
'wenn y =1, dann gar nix machen, weil die summen eh passen
If y = 1 Then GoTo skip
'summenzeile einfügen und die Zellen darüber addieren
Rows(z - 1 & ":" & z - 1).Copy
Rows(z & ":" & z).Insert Shift:=xlDown
On Error GoTo fehler:
'Spalten I bis AM mit der Summenformel belegen
Set summe = Range("I" & z & ":AM" & z)
summe.Formula = "=SUM(R[-" & y & "]C:R[-1]C)"
Calculate
'als Festwerte wegkopieren.
summe.Copy
summe.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'Detailzeilen immer löschen
bereich = z - y & ":" & z - 1
Rows(bereich).Rows.Delete
z = z - y
skip:
j = j + 1
gruppe = Cells(z + 1, sgroup).Value
y = 0
End If
z = z + 1
Loop
Exit Sub
fehler:
MsgBox "Fehler beim Aufaddieren! (evtl. Textfeld gewählt)", vbCritical, "Fehler"
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub