wollte in einem VBA Projekt Daten änder aber ich bekomme es einfach nicht hin. Bei bestimmten Zellen soll wenn diese angeklickt werden den Wert darin steht in eine anderen Zelle übernommen werden.
Beispiel: 1. Wurf Spieler 1 wirft in Zelle b10 Wert 3 dieser Wert soll dann in Zelle L5 übernommen werden. Wurf 2 in Zelle e12 Wert 45 dieser soll zum 1. Wurf addiert werden das Gleiche mit dem 3. Wurf und die würfe sollen einzel in den Zellen B18 je welche Spieler an der Reihe ist addiert werden. Habe VBA hier eingefügt und Die Darttabelle hochgeladen damit man sich die anschauen kann und hoffe, das diese Datei nicht als Vieren verseucht abgelehnt wird, da ich das schon einmal hatte und ein Kollege hatte festgestellt das Datei in Ordnung ist. Code Lautet:
Private Sub CommandButton1_Click()
Public arrRueck(2) As Variant
Sub rueckgaengig() HIER ZEIGT ER MIR EIN FEHLER AN
'bei Würfen 1 Wurf abziehen
If Range(arrRueck(0)).Value - 1 > 0 Then
Range(arrRueck(0)).Value = Range(arrRueck(0)).Value - 1
Else
'falls 0, dann 0 löschen
Range(arrRueck(0)).ClearContents
End If
'alte Punktezahl zurückschreiben
Range(arrRueck(1)).Value = arrRueck(2)
End Sub
Private Sub SpinButton1_Change()
If SpinButton1.Value < 1 Then SpinButton1.Value = ActiveSheet.Range("c1")
If SpinButton1.Value > ActiveSheet.Range("c1") Then SpinButton1.Value = 1
ActiveSheet.Range("g1") = SpinButton1.Value
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim lngSpieler As Long
Dim lngSpalte As Long
Dim lngPunktSpalte As Long
Dim lngZeile As Long
Static lngErgebnis As Long
'Nur bei Klick im Bereich von B4 bis f16 ausführen
If Not Intersect(Target, Range("B4:f16")) Is Nothing Then
'nicht in Zelle klicken
Cancel = True
'Nummer des Spielers einlesen
lngSpieler = Range("g1").Value
'Würfe addieren
'Spieler im Bereich A18 bis A77 suchen
For lngZeile = 18 To 77
If Cells(lngZeile, 1).Value = "Sp" & lngSpieler Then
'Spalte für den Eintrag des Wurfes suchen
For lngSpalte = 2 To 18
'Prüfen, ob Wert in Zelle kleiner 3 ist
If Cells(lngZeile, lngSpalte).Value < 3 Then
'Wurf addieren
Cells(lngZeile, lngSpalte).Value = Cells(lngZeile, lngSpalte).Value + 1
'Schleife verlassen
GoTo weiter:
End If
Next lngSpalte
End If
Next lngZeile
'Sprungmarke
weiter:
'Punkte addieren, aber nur, wenn kein Fehlwurf
If Target.Address <> "$f$16" Then
'Spieler im Bereich L3 bis S17 suchen
For lngPunktSpalte = 11 To 18 Step 2
If Cells(3, lngPunktSpalte).Value = "Spieler " & lngSpieler Then
'alter Punktestand in Variable speichern, aber nur, wenn der erste Wurf ausgeführt wurde
If Cells(lngZeile, lngSpalte).Value = 1 Then lngErgebnis = Cells(5, lngPunktSpalte)
'Punkte addieren
Cells(5, lngPunktSpalte) = Cells(5, lngPunktSpalte) + Target.Value
'Prüfen, ob überworfen
If Cells(6, lngPunktSpalte).Value < 0 Then
'alten Punktestand zurückschreiben
Cells(5, lngPunktSpalte) = lngErgebnis
'da keine weiteren Würfe mehr, Anzahl der Würfe auf 3 hochsetzen
Cells(lngZeile, lngSpalte).Value = 3
End If
'Schleife verlassen
Exit For
End If
Next lngPunktSpalte
End If
End If
End Sub
