• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Event uitbijters

Status
Niet open voor verdere reacties.
S

Symphysodon

Gebruiker
Lid geworden
14 dec 2012
Berichten
468
Beste forummers,

Ik heb een tabel met een x-tal kolommen met per kolom 8 te toetsen cellen. Nu wil ik voordat de kolommen getoetst worden, de getallen gecontroleerd hebben op uitbijters en tekst. De uitbijters worden rood gemarkeerd, tekst wordt verwijderd.

Nu heb ik een poging gedaan om het in een event te krijgen, maar de code loopt niet lekker. Als ik begin met het invullen van de tabel worden er meerdere getallen per kolom rood. De bedoeling is dat 1x een uitbijtertest gedaan wordt, dus per kolom maximaal 1 rood getal.

Op het moment als ik getallen verwijder krijg ik een pop-up met de melding: De uitvoering van de programmacode is onderbroken... Doorgaan, …

De code is als volgt:
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Dim n, m, A, B, t, xgem, sd, KW, tc, cl As Variant
Set rng = [a1:a8]

If IsEmpty(rng.Value) Then Exit Sub
If Not Intersect(Target, rng) Is Nothing Then

    On Error Resume Next
    If Target <> "" Then
        If Not IsNumeric(Target) Then
            ''MsgBox "Geen tekst a.u.b.!!"
            Target.Value = ""
            Exit Sub
        Else
            Application.ScreenUpdating = False
            Target.Font.Color = vbBlack
            n = Application.WorksheetFunction.CountA(rng)
            m = n - 2
            A = 0.05
            B = A / (2 * n)
            If n = 1 Then Exit Sub
            t = Application.WorksheetFunction.TInv(2 * B, m)
            xgem = Application.WorksheetFunction.Average(rng)
            sd = Application.WorksheetFunction.StDev(rng)
            KW = ((n - 1) / n ^ 0.5) * (t ^ 2 / ((n - 2) + t ^ 2)) ^ 0.5
            For Each cl In rng
                    tc = Abs((cl - xgem) / sd)
                    If tc > KW Then
                        cl.Font.Color = -16776961
                    End If

            Next
            Application.ScreenUpdating = True
        End If
    End If
End If
End Sub

Dit is vooralsnog voor 1 kolom.

Hoe krijg ik dit voor elkaar. Alvast bedankt voor de antwoorden.

grt
Marco
 

Bijlagen

  • Event uitbijters.xlsm
    15,2 KB · Weergaven: 31
Als je de test maar een keer wil doen, maar meerdere waarden voldoen aan de uitbijter test, wat dan?
 
Wat zijn 'uitbijters' ?

Gebruik altijd application.counta ipv application.worksheetfunction.counta

Ik zou hiervoor geen gebeurtenis gebruiken. Als begin van de code voor de uiteindelijke test lijkt me handiger.
 
Laatst bewerkt:
In goed Nederlands "Outliers" :) Cijfers die volgens een bepaalde statustische methode gemarkeerd mogen worden als buiten het normale bereik.
 
In principe komt er met deze test (grubbs) maar 1 waarde uit.

Misschien is het inderdaad handiger om er een functie van te maken. Het is op werkblad niveau, er komt verder geen vba aan te pas.

zoiets:
Code: 
Function uitbijter(rng As Range, n, m, A, B, t, xgem, sd, KW, tc, cl, u)

Application.ScreenUpdating = False

Set rng = Selection

rng.Font.Color = vbBlack
n = Application.CountA(rng)
m = n - 2
A = 0.05
B = A / (2 * n)
If n = 1 Then Exit Function
t = Application.WorksheetFunction.TInv(2 * B, m)
xgem = Application.WorksheetFunction.Average(rng)
sd = Application.WorksheetFunction.StDev(rng)
KW = ((n - 1) / n ^ 0.5) * (t ^ 2 / ((n - 2) + t ^ 2)) ^ 0.5
For Each cl In rng
    tc = Abs((cl - xgem) / sd)
    If tc > KW Then
        cl.Font.Color = vbRed
        cl.Value = u
    End If
Next
uitbijter = u
Application.ScreenUpdating = True
End Function

De bedoeling is dat in een cel onder de metingen een als dan functie komt te staan met daarin: als de uitbijtertest positief is dan msgbox "eerst uitbijter verwijderen", anders toetsen met formule …

Als ik de uitbijter functie in een aparte cel uitvoer krijg ik de melding: #waarde
 
Dit is beter denk ik:

Code: 
Function uitbijter(rng As Range)
Dim n, m As Integer
Dim A, B, t, xgem, sd, KW, tc, u As Double
Dim cl As Range

Application.ScreenUpdating = False


rng.Font.Color = vbBlack
n = Application.CountA(rng)
m = n - 2
A = 0.05
B = A / (2 * n)
If n = 1 Then Exit Function
t = Application.WorksheetFunction.TInv(2 * B, m)
xgem = Application.WorksheetFunction.Average(rng)
sd = Application.WorksheetFunction.StDev(rng)
KW = ((n - 1) / n ^ 0.5) * (t ^ 2 / ((n - 2) + t ^ 2)) ^ 0.5
For Each cl In rng
    tc = Abs((cl - xgem) / sd)
    If tc > KW Then
        cl.Font.Color = vbRed
        u = cl.Value
    End If
Next
uitbijter = u
Application.ScreenUpdating = True
End Function
 
Laatst bewerkt:
Laatst bewerkt:
Lees jij suggesties wel eens ?
 
@ snb Heb ik een suggestie gemist? de jouwe heb ik opgevolgd, zie zowel #5 als #6

@alphamax Ik weet niet meer precies waar de gebruikte formule vandaan komt Miller and Miller misschien. Maar het gaat mij niet om de formule maar om de uitvoering. De functie in #6 werkt zolang er in de reeks een uitbijter zit, op het moment er geen uitbijter zit krijg ik een foutmelding #waarde. Logisch want dat is (nog) niet ingebouwd, ik krijg het alleen nog niet voor mekaar.
 
Als ik in de functie de melding #waarde voorkom met On Error Resume Next en
Code: 
If u <> 0 Then
    uitbijter = u
Else: Exit Function
End If
dan gaat het goed. Als de reeks geen uitbijter bevat dan retourneert de functie de waarde 0.

Code: 
Function uitbijter(rng As Range)
Dim n, m As Integer
Dim A, B, t, xgem, sd, KW, tc, u As Double
Dim cl As Range

Application.ScreenUpdating = False


rng.Font.Color = vbBlack
n = Application.CountA(rng)
m = n - 2
A = 0.05
B = A / (2 * n)
If n = 1 Then Exit Function
t = Application.WorksheetFunction.TInv(2 * B, m)
xgem = Application.WorksheetFunction.Average(rng)
sd = Application.WorksheetFunction.StDev(rng)
KW = ((n - 1) / n ^ 0.5) * (t ^ 2 / ((n - 2) + t ^ 2)) ^ 0.5
On Error Resume Next
For Each cl In rng
    tc = Abs((cl - xgem) / sd)
    If tc > KW Then
        cl.Font.Color = vbRed
        u = cl.Value
    End If
Next
If u <> 0 Then
    uitbijter = u
Else: Exit Function
End If
Application.ScreenUpdating = True
End Function
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan