Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1684to1688
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

VBA: Ausreisser identifizieren und löschen

VBA: Ausreisser identifizieren und löschen
01.04.2019 11:49:43
Roman
Hallo zusammen
Ich suche ein VBA-Code um Ausreisser zu identifizieren und zu löschen:
Ich habe im Zellbereich C2:C3000 Daten. Diese Daten können Ausreisser enthalten, welche ich mittels VBA-Code identifizieren und dann gleich löschen möchte.
Als ersten Schritt soll der Durchschnitt (arithmetisches Mittel) des Zellbereichs ermittelt werden.
Dann soll die Standardabweichung des Zellbereichs ermittelt werden.
Die nächsten Schritte sollten so aufgesetzt sein, dass nun von Zelle C2 beginnend jeder Zellinhalt nach unten bis Zelle C3000 gegenüber dem Durchschnitt verglichen wird. Die Werte mit Entfernungen von mehr als +/- 3 Standardabweichungen gegenüber dem Durschnitt soll der Zellinhalt gelöscht werden (3 Sigma-Regel).
Ich wäre sehr froh, wenn jemand mir ein möglicher Code schreiben könnte. Vielen Dank schon jetzt für Eure Hilfe.
Gruss
Roman

10
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA: Ausreisser identifizieren und löschen
01.04.2019 13:19:32
Daniel
Hallo Roman,
hab's mal versucht nachzuvollziehen. Schau mal ob es das ist was du meintest.
https://www.herber.de/bbs/user/128809.xlsm
Gruß
Daniel
AW: VBA: Ausreisser identifizieren und löschen
01.04.2019 14:49:03
Roman
Hoi Daniel
Vielen Dank schon mal für deinen Lösungsversuch. Es geht in die richtige Richtung. Der unten von mir fett markierten VBA-Bereich müsste aber nachgebessert werden. Und zwar wie folgt:
- Werte sind ok, wenn sie im Bereich zwischen Mittelwert + 3*Standardabweichung und Mittelwert - 3*Standardabweichung liegen.
- Werte die ausserhalb dieses Bereiches sind müssen gelöscht werden.
Sub Ausreisser()
Dim Zelle As Range
Application.Calculation = xlCalculationManual
Cells(2, 4).FormulaR1C1 = "=AVERAGE(RC[-1]:R[2998]C[-1])"
Cells(2, 5) = Cells(2, 4).Value
Cells(3, 4).FormulaR1C1 = "=STDEV.P(R[-1]C[-1]:R[2997]C[-1])"
Cells(3, 5) = Cells(3, 4).Value
For Each Zelle In Columns(3).Cells.SpecialCells(xlCellTypeConstants)
If Abs(Zelle.Value - Cells(2, 5)) > 3 Then
Zelle.Clear
End If
Next Zelle
Application.Calculation = xlCalculationAutomatic
End Sub

Anzeige
AW: VBA: Ausreisser identifizieren und löschen
01.04.2019 15:19:32
Daniel
Kenne deine Daten nicht, in meinen Testdaten kommen diese Bedingungen nicht vor. Müsste aber so gehen:
Sub Ausreisser()
Dim Zelle As Range
Dim Mittelw As Double, StandA As Double
Application.Calculation = xlCalculationManual
Cells(2, 4).FormulaR1C1 = "=AVERAGE(RC[-1]:R[2998]C[-1])"
Cells(2, 5) = Cells(2, 4).Value
Mittelw = Cells(2, 5)
Cells(3, 4).FormulaR1C1 = "=STDEV.P(R[-1]C[-1]:R[2997]C[-1])"
Cells(3, 5) = Cells(3, 4).Value
StandA = Cells(3, 5)
For Each Zelle In Columns(3).Cells.SpecialCells(xlCellTypeConstants)
If Zelle.Value > Mittelw + 3 * StandA Or Zelle.Value 

Anzeige
AW: VBA: Ausreisser identifizieren und löschen
01.04.2019 16:27:18
Roman
Ich habe zwischenzeitlich rumprobiert und komme dank deiner Hilfe auf ein funktionierendes Resultat. Ich habe nun den VBA-Code in mein richtiges Arbeitsfile kopiert und angepasst. Der Datenbereich ist E10:E3000.
Jetzt habe ich nur noch das Problem, dass ich die Code-Anpassung von Columns(3) in den Datenbereich von E10:E3000 nicht hinbekomme. Ich bekomme immer eine Fehlermeldung (unten fett hervorgehoben). Was muss ich tun, damit es funktioniert?
Sub Remove_Ausreisser()
Dim Zelle As Range
Application.Calculation = xlCalculationManual
Range("Q2").Formula = "=AVERAGE(E10:E3000)"
Range("R2") = Range("Q2").Value
Range("Q3").Formula = "=STDEV(E10:E3000)"
Range("R3") = Range("Q3").Value
'For Each Zelle In Columns(3).Cells.SpecialCells(xlCellTypeConstants)
For Each Zelle In Range("E10:E3000").Cells.SpecialCells(xlCellTypeConstants)
If Abs(Zelle.Value > (Range("R2") + 3 * (Range("R3")))) Then
Zelle.Clear
End If
Next Zelle
For Each Zelle In Range("E10:E3000").Cells.SpecialCells(xlCellTypeConstants)
If Abs(Zelle.Value 

Anzeige
..ohne .Cells hinter Range... owT
01.04.2019 16:40:31
robert
AW: ..ohne .Cells hinter Range... owT
01.04.2019 16:48:22
Daniel
Hallo robert - du hast recht, das Cells ist überflüssig. Allerdings auch nicht falsch...
AW: VBA: Ausreisser identifizieren und löschen
01.04.2019 16:45:28
Daniel
Was steckt denn in den Zellen im durchsuchten Bereich? Gehe davon aus, dass du die gesuchten Zelltypen ändern musst. Also zum Beispiel xlCellTypeFormulas anstelle Constants. Wenn da angenommen nur Formeln drin stehen, findet er keine der Specialcells und läuft in einen Fehler.
AW: VBA: Ausreisser identifizieren und löschen
02.04.2019 14:59:23
Roman
Ursprünglich waren in den Zellen Formeln drin für einen Datenbezug aus einer externen Quelle. Ich habe nun einen Zwischenschritt eingebaut und kopiere die Zellen und füge sie dann als Werte wieder ein. Mit xlCellTypeVisible läuft nun mein Code perfekt. Alles funktioniert nun wie es soll. Hier mein Code:
Sub Remove_Ausreisser()
Dim Zelle As Range
Application.Calculation = xlCalculationManual
Sheets("Peer_Analysis").Range("Q2").Formula = "=AVERAGE(E10:E3000)"
Sheets("Peer_Analysis").Range("Q3").Formula = "=STDEV(E10:E3000)"
Sheets("Peer_Analysis").Range("Q2:Q3").Copy       'kopiert die beiden berechneten Werte
Sheets("Peer_Analysis").Range("R2:R3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks _
:=False, Transpose:=False
For Each Zelle In Sheets("Peer_Analysis").Range("E10:E3000").Cells.SpecialCells( _
xlCellTypeVisible)  'sucht und löscht die Werte mit Abweichungen zum Mittelwert von +3 Standardabweichungen
If Abs(Zelle.Value > (Sheets("Peer_Analysis").Range("R2") + 3 * (Sheets("Peer_Analysis"). _
Range("R3")))) Then
Zelle.Clear
End If
Next Zelle
For Each Zelle In Sheets("Peer_Analysis").Range("E10:E3000").Cells.SpecialCells( _
xlCellTypeVisible)  'sucht und löscht die Werte mit Abweichungen zum Mittelwert von -3 Standardabweichungen
If Abs(Zelle.Value 
Der VBA-Code funktioniert super für den von mir definierten Datenbereich (E10:E3000). Nun ist es so, dass ich den Code erweitern möchte um weitere 60 Datenbereiche. Angefangen bei J10:J3000, dann K10:K3000, dann L10:L3000 bis ganz zuletzt BQ10:BQ3000. Ich möchte natürlich nicht den obigen Code 60x kopieren und anpassen. Besteht die Mögichkeit ein Schlaufe zu bauen? Wie müsste die aufgesetzt sein?
Anzeige
AW: VBA: Ausreisser identifizieren und löschen
02.04.2019 15:10:29
Daniel
Als Ansatz:
Packe das Ganze in eine weitere For Schleife. Zähle die benutzten Spalten und lasse die Schleife so oft laufen, bis die letzte Spalte durch ist. Gestalte dann die Ranges flexibel, zum Beispiel
Range(Cells(Zeile2, Spalte), Cells(letzteZeile, Spalte))
Wobei Spalte hier die Nummer des Durchlaufs der For Schleife wäre. Hoffe das ergibt Sinn für dich, glaub du schaffst das ganz gut und vom Probieren lernt man am Meisten!
Grüße

306 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige