Makro zur Fehlerkorrektur

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) If Target.Value > 0.5 Or Target.Value < -0.5 Then If Target.Row >= 13 And _ Target.Offset(-13, 0).Value <> 0 And _ Target.Offset(13, 0).Value <> 0 Then If vbYes = MsgBox("Aktive Zelle wird geändert!", vbYesNo, "Wert ändern!") Then Target.Value = (Target.Offset(-13, 0).Value + Target.Offset(13, 0).Value) / 2 Cancel = True End If Else MsgBox "Mind. einer der Offsetwerte ist 0 !", vbOKOnly + vbExclamation, "Wert NICHT geändert!" End If End If End Sub

Hallo Hansueli,
Naja, für mich ich als totalen VBA-Anfänger ist vieles unmöglich ;-)
Also:
a)Die Suche soll nur für einen bestimmten Bereich gelten, in meinem Fall von E40:F250
b)Werte bei denen keine Offset-Werte existieren sollten den nachfolgenden +13 bzw. vorergehenden -13 Wert annehmen (sieht jedoch nach einem großen Aufwand aus, müssen daher nicht unbedingt berücksichtigt werden
c)Offset-Werte=0 sollten gleich behandelt werden wie >0.5 bzw. d)Bei dieser Art der Messung ist die Wahrscheinlichkeit dafür sehr gering daher kann das ruhig erlaubt sein (sollte es tatsächlich vorkommen, kann der Fehler auch "manuell" abgeschätzt werden)
Vielen Dank für deine Hilfe und Geduld!
Lg,
Rudi

Hallo Rudi,
Also: Kopiere folgende Makro in ein Modul.
Ev. die kommentierten Zeilen anpassen, falls Bereich oder Werte ändern und laufen lassen.


Sub ChangeToAverage()
Dim dBelow, dAbove As Double
Dim sOffsetM, sOffsetP, sCntA, sCntC As Single
Dim rThisRange, rCell As Range
rThisRange = "E40:F250" ' Dieser Bereich wird abgesucht
dBelow = -0.5           ' Werte kleiner werden geändert
dAbove = 0.5            ' Werte grösser werden geändert
sOffsetM = -13          ' Position Wert Minus-Zeilenrichtung
sOffsetP = 13           ' Position Wert Plus-Zeilenrichtung
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
sCntA = 0
sCntC = 0
For Each rCell In ActiveSheet.Range(rThisRange)
If rCell.Value > dAbove Or rCell.Value < dBelow Then sCntA = sCntA + 1
If rCell.Row > ActiveSheet.Range(rThisRange).Row + sOffsetP - 1 And _
rCell.Row < ActiveSheet.Range(rThisRange).Row + ActiveSheet.Range(rThisRange).Rows.Count + sOffsetM Then
If rCell.Value > dAbove Or rCell.Value < dBelow Then
rCell.Value = (rCell.Offset(sOffsetM, 0).Value + rCell.Offset(sOffsetP, 0).Value) / 2
sCntC = sCntC + 1
End If
End If
Next
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
' Eventuell weglassen, wenn keine Meldung erwünscht !
MsgBox sCntC & " Zellen geändert!" & vbCrLf & _
sCntA & " Zellen haben noch einen Wert ausserhalb des Limits!", vbOKOnly, "Änderungen gemacht!"
End Sub

Gruss Hansueli

Beliebteste Forumthreads (12 Monate)

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread