Zahl in Zelle automatisch erhöhen von 0,1,2 3 usw.

Question

Hallo zusammen und einen schönen Sonntag wünsche ich euch,

möchte gerne, das in einer Zelle sich die Zahl automatisch erhöht wenn in Zelle LD 5 grösser gleich 50 dann Null, wenn LD 5 kleiner 50 oder 0 dann 1in sonst immer um 1 erhöhen bis die Null erreicht ist.

Kann mir jemand dabei eine Lösung vorschlagen

VBA wäre sehr schön.

Vergessen: Ergebnis soll in Zelle LH7 erscheinen

Habe einen Vorschlag vom Internet aber das funktioniert nicht. Vielleicht mache ich auch etwas falsch.

Das ist der Vorschlag:   If(LD5=0;"";LD5+1) Fehlermeldung: Name

Answer 1

Hallo M.O. du hast wahrscheinlich vergessen aber nicht schlimm. Habe eine Lösung erstellt die auch funktioniert. Das ist die Lösung.

'Ziel ist die Zelle, die geändert wurde
'bereich ist die Vereinigung der Bereiche B5:B14, E5:E14 und C15
Dim bereich As Range
Set bereich = Union(Range("B5:B14"), Range("E5:E14"), Range("C15"))

'schnitt ist die Schnittmenge von Ziel und bereich
Dim schnitt As Range
Set schnitt = Intersect(Target, bereich)

'fehlwurf ist eine Variable, die die Anzahl der Fehlwürfe zählt
Dim fehlwurf As Integer
'wenn die Zelle in der Spalte 422 leer ist, setze fehlwurf auf 0
If IsEmpty(Cells(1 + Range("G1").Value, 422)) Then
    fehlwurf = 0
Else
    'sonst übernehme den Wert aus der Zelle
    fehlwurf = Cells(1 + Range("G1").Value, 422)
End If

'Wenn schnitt nichts ist, bedeutet das, dass Ziel nicht in bereich liegt
If schnitt Is Nothing Then
    'Doppel
    'erhöhe fehlwurf um 1
    fehlwurf = fehlwurf + 1
    'schreibe fehlwurf in die Zelle
    Cells(1 + Range("G1").Value, 422) = fehlwurf
Else
    'kein Doppel
    'setze fehlwurf auf 0 zurück
    fehlwurf = 0
    'schreibe fehlwurf in die Zelle
    Cells(1 + Range("G1").Value, 422) = fehlwurf
End If

Gruß Adde

Answer 2

Hallo M.O. ich denke du hast es vergessen mit zu antworten,

habe eine Lösung erstellt, habe sehr lange dafür gebraucht. Das ist die Lösung:

If Not Intersect(Target, Range("B2:B14,E2:E14,C15")) Is Nothing Then
        'Doppel
        Cells(1 + Range("J1").Value, 425) = "1"
    Else
        'kein Doppel
        Cells(1 + Range("J1").Value, 425) = "+1"
End If
If Not Intersect(Target, Range("B2:B14,E2:E14,C15")) Is Nothing Then
        'Doppel
        Cells(1 + Range("J1").Value, 424) = "1"
    Else
        'kein Doppel
        Cells(1 + Range("J1").Value, 424) = "-1"
End If
'Ziel ist die Zelle, die geändert wurde
'bereich ist die Vereinigung der Bereiche B5:B14, E5:E14 und C15
Dim bereich As Range
Set bereich = Union(Range("B5:B14"), Range("E5:E14"), Range("C15"))

'schnitt ist die Schnittmenge von Ziel und bereich
Dim schnitt As Range
Set schnitt = Intersect(Target, bereich)
'fehlwurf ist eine Variable, die die Anzahl der Fehlwürfe zählt
Dim fehlwurf As Integer
'wenn die Zelle in der Spalte 422 leer ist, setze fehlwurf auf 0
If IsEmpty(Cells(1 + Range("G1").Value, 422)) Then
    fehlwurf = 0
Else
    'sonst übernehme den Wert aus der Zelle
    fehlwurf = Cells(1 + Range("G1").Value, 422)
End If

'Wenn schnitt nichts ist, bedeutet das, dass Ziel nicht in bereich liegt
If schnitt Is Nothing Then
    'Doppel
    'erhöhe fehlwurf um 1
    fehlwurf = fehlwurf + 1
    'schreibe fehlwurf in die Zelle
    Cells(1 + Range("G1").Value, 422) = fehlwurf
Else
    'kein Doppel
    'setze fehlwurf auf 0 zurück
    fehlwurf = 0
    'schreibe fehlwurf in die Zelle
    Cells(1 + Range("G1").Value, 422) = fehlwurf
End If

Grus Adde