Ein bestehendes VBA erweitern?

Question

Hallo und guten morgen

An die VBA spezialisten

besteht die Möglichkeit dieses VBA so zu erweitern, das wenn man sich überworfen hat die Anzahl der Würfe auch anpassen kann.

Beim überwerfen wird der Letzte Stand der Punktzahl übernommen, dies ist auch OK.  Doch der Wurf 6 bleibt bestehen.

'Spalte für den Eintrag der Würfe ermitteln

lngWSpalte = WorksheetFunction.RoundDown(Cells(lngSZeile, 25).Value / 3, 0) + 2

'Würfe der Runde auf Null setzen, wenn überworfen

If bUeberw = True Then

For i = 1 To Cells(lngSZeile, lngWSpalte).Value

Cells(lngWZeile, lngSpalte + Cells(lngSZeile, lngWSpalte).Value - i) = 0

Next i

End If

Beispiel ich überwerfe mich im 6ten bleibt die 6  oder 7ten Wurf die 7 stehen, das dann 9 erscheint, Beim 10,11ten Wurf auf 12, beim 13,14 die 15 usw. erscheint

Wäre toll wenn jemand hierfür eine Lösung hätte. Gruß Adde

Answer 1

Hallo Adde,

das ist der falsche Teil des Codes .

Ersetze mal die Zeile

'Anzahl Würfe erhöhen
Cells(lngSZeile, lngWSpalte) = Cells(lngSZeile, lngWSpalte).Value + 1

durch

'Anzahl Würfe erhöhen
If bUeberw = True Then
 'falls überworfen, dann ggf. auf den nächsten 3er-Schritt aufrunden
  Cells(lngSZeile, lngWSpalte) = (Int(Cells(lngSZeile, lngWSpalte).Value / 3) + 1) * 3
 Else
  Cells(lngSZeile, lngWSpalte).Value = Cells(lngSZeile, lngWSpalte).Value + 1
End If

Das sollte dann so funktionieren, wie du willst (wenn ich dich richtig verstanden habe).

Funktioniert übrigens nach dem selben Prinzip wie hier erläutert.

Gruß

M.O.

Answer 2

Halo M.O.

vielen lieben Dank für deine Antwort. Ja, du hast mich richtig verstanden. Habe es eingesetzt und es funktioniert.

Was wäre ich ohne dich.

Gruß Adde