AW: Gern, + kleine Erläuterung bei Interesse
06.07.2016 14:59:24
Ben
Hallo Michael,
durch das Einfügen des Codes in mein Excel-Tool hat sich die Gesamtrechenzeit von 2 Minuten auf jetzt nur noch ~20 Sekunden verkürzt. Ich habe mir noch die "Zeit" (j) ausgeben lassen, zusätzliche zwei weitere Summen einer angrenzenden Spalte und den Mittelwert einer Spalte ausgeben lassen (siehe Code).
(nicht schön, aber es klappt ;-) )
Option Explicit
Sub Summenbildung()
Dim Wb As Workbook
Dim Ws As Worksheet
Dim Ws1 As Worksheet
Dim aW, aW1, aW2, aW3
Dim i As Long
Dim s As Double
Dim s1 As Double
Dim s2 As Double
Dim s3 As Double
Dim j As Long
Dim clc
'Performance erhöhen
With Application
clc = .Calculation 'Modus der Formelberechnung merken
.Calculation = xlCalculationManual 'Autom. Formelberechnung AUS
.ScreenUpdating = False 'Bildschirm-Aktualisierung AUS
End With
'Mappe, Blatt und Bereich der Werte bestimmen
Set Wb = ThisWorkbook
Set Ws = Wb.Worksheets("Daten")
With Ws
'Gesamter Wertebereich wird in ein Array geschrieben
aW = Application.Transpose(.Range("A3:A" & .Cells(.Rows.Count, 1).End(xlUp).Row))
aW1 = Application.Transpose(.Range("B3:B" & .Cells(.Rows.Count, 1).End(xlUp).Row))
aW2 = Application.Transpose(.Range("D3:D" & .Cells(.Rows.Count, 1).End(xlUp).Row))
aW3 = Application.Transpose(.Range("E3:E" & .Cells(.Rows.Count, 1).End(xlUp).Row))
End With
'Anstatt die einzelnen Zellen durchzugehen, die Array-Elemente bearbeiten
'1 bis zum letzten Element des Arrays (= Wert der letzten Zelle des Werte-Bereichs)
For i = 1 To UBound(aW)
'Summe ist zunächst der Wert des i-Elements des Arrays
s = aW(i)
s1 = aW1(i)
s2 = aW2(i)
s3 = aW3(i)
j = i 'Ein Zähler
'Solange die Summe UBound(aW) Then Exit For
'Zur Summe wird jeweils der Wert des j-Elements des Arrays zugeschlagen
s = s + aW(j)
s1 = s1 + aW1(j)
s2 = s2 + aW2(j)
s3 = s3 + aW3(j)
Loop
'Array startet ab 1, die Zielzellen aber erst ab Zeile 3
'deshalb schreiben wir die jeweilige Summe immer in die Zelle i + 2 (in die 3. Spalte)
Set Ws = Wb.Worksheets("MAW")
Ws.Cells(i + 2, 5) = s
Ws.Cells(i + 2, 6) = s1
Ws.Cells(i + 2, 7) = s2 / (j - i + 1) 'Mittelwert
Ws.Cells(i + 2, 8) = s3
Worksheets("MAW").Cells(i + 2, 3) = j - 1 'Zeitpunkt Ende (letzte Stelle)
Next i
'Aufräumen
Set Wb = Nothing
Set Ws = Nothing
Erase aW
With Application
.Calculation = clc
.ScreenUpdating = True
End With
End Sub
Ich habe noch weitere Punkte gefunden wo ich die Rechenzeit verkürzen kann. Allerdings sind es oft nur Kleinigkeiten.
Hast du allgemein eine Empfehlung wo ich mir das Programmieren mit Arrays aneignen kann?
Nochmal vielen Dank!