PDA

Vollständige Version anzeigen : Mittelwert und Standardabweichung


babba1323
31.08.2017, 07:38
Hallo,
ich benötige Hilfe.
Meine Tabelle hat über 60.000 Zeilen und die Formeln Mittelwert und Standardabweichung legen alles lahm, deshalb möchte ich dies über VBA berechnen lassen.

Spalte A / Spalte B
ID / Werte

1. Schritt:
von allen selben IDs (aus Spalte A) soll von deren Werten (Spalte B) der Mittelwert und die 2fache Standardabweichung (Stichprobe) ermittelt werden
2. Schritt
und dann alle Zeilen mit den IDs die außerhalb des Bereiches Mittelwert +- 2fache Standardabweichung liegen in ein neues Tabellenblatt kopiert werden

Vielen Dank schon im Voraus

Der Steuerfuzzi
31.08.2017, 07:46
Hallo,

ich bin mir nicht sicher, ob das ganze über VBA schneller sein wird. Kannst Du mal eine Beispieldatei hochladen, damit man mal die Berechnungsdauer nachvollziehen kann?

babba1323
31.08.2017, 08:18
Hallo Michael,

anbei die Datei (auf 3550 Zeilen gekürzt, da sonst zu groß). Wenn ich jetzt noch die Formel der Standardabweichung nach unten ziehe (bei den ursprünglich 63.000 Zeilen), stürzt mir Excel ab.

Vg
Martin

Oge
31.08.2017, 09:39
Hallo babba,

hier einmal eine VBA-Lösung:
Option Explicit
Private Sub cbTuwat_Click()
Dim lngAnzCopy
Dim lngZeile As Long
Dim varKey As Variant
Dim varListe As Variant
Dim varAusgabe As Variant
Dim rngAusgabe As Range
Dim dictA As Object
Dim dictM As Object
Dim dictS As Object
Dim dictQ As Object

lngAnzCopy = 0

varListe = ThisWorkbook.Names("Liste").RefersToRange.Value
Set rngAusgabe = ThisWorkbook.Names("Ausgabe").RefersToRange
Set dictA = CreateObject("Scripting.Dictionary")
Set dictM = CreateObject("Scripting.Dictionary")
Set dictS = CreateObject("Scripting.Dictionary")
Set dictQ = CreateObject("Scripting.Dictionary")
'------------------------------------
' Einlesen Anzahl und Summe
'------------------------------------
For lngZeile = 1 To UBound(varListe, 1)
dictA(varListe(lngZeile, 1)) = dictA(varListe(lngZeile, 1)) + 1
dictS(varListe(lngZeile, 1)) = dictS(varListe(lngZeile, 1)) + varListe(lngZeile, 2)
Next lngZeile
'------------------------------------
' Mittelwerte ermitteln
'------------------------------------
For Each varKey In dictA
dictM(varKey) = dictS(varKey) / dictA(varKey)
Next varKey
'------------------------------------
' Summe der Quadratischen Abweichung
'------------------------------------
For lngZeile = 1 To UBound(varListe, 1)
dictQ(varListe(lngZeile, 1)) = dictQ(varListe(lngZeile, 1)) + (varListe(lngZeile, 2) - dictM(varListe(lngZeile, 1))) ^ 2
Next lngZeile
'------------------------------------
' Ausgabe Mittelwert und Standardabweichung
'------------------------------------
For lngZeile = 1 To UBound(varListe, 1)
varListe(lngZeile, 3) = dictM(varListe(lngZeile, 1))
varListe(lngZeile, 4) = Sqr(dictQ(varListe(lngZeile, 1)) / dictA(varListe(lngZeile, 1)))
If (varListe(lngZeile, 2) - varListe(lngZeile, 3)) ^ 2 > (2 * varListe(lngZeile, 4)) ^ 2 Then
lngAnzCopy = lngAnzCopy + 1
End If
Next lngZeile

ThisWorkbook.Names("Liste").RefersToRange.Value = varListe
'------------------------------------
' Ausgabe Kopie
'------------------------------------
ReDim varAusgabe(1 To lngAnzCopy, 1 To 2)
lngAnzCopy = 0
For lngZeile = 1 To UBound(varListe, 1)
If (varListe(lngZeile, 2) - varListe(lngZeile, 3)) ^ 2 > (2 * varListe(lngZeile, 4)) ^ 2 Then
lngAnzCopy = lngAnzCopy + 1
varAusgabe(lngAnzCopy, 1) = varListe(lngZeile, 1)
varAusgabe(lngAnzCopy, 2) = varListe(lngZeile, 2)
End If
Next lngZeile
rngAusgabe.Resize(UBound(varAusgabe, 1), UBound(varAusgabe, 2)) = varAusgabe
End Sub


Das Programm benötigt zur Zeit zwei benannte Bereiche ( da ich ungern mit festen Adressen im Programm arbeite).
1) einen benannten Bereich "Liste" von mindestens 4 Spalten
In der ersten Spalte erwartet das Programm die ID und in der zweiten Spalte den Wert.
In die Spalten drei und vier werden der Mittelwert und die Standardabweichung geschrieben.
2) eine benannte Zelle "Ausgabe"
Ab dieser Zelle werden die Ausreisser eingetragen. Sie kann beliebig in der Datei positioniert werden, auch in andere Arbeitsblätter.

babba1323
01.09.2017, 11:00
funktioniert perfekt! Super vielen Dank.