Thema Datum  Von Nutzer Rating
Antwort
Rot Dartsspiel
 02.08.2018 08:46:37 PSA
Solved
02.08.2018 13:31:41 PSA
Solved

Ansicht des Beitrags:
Von:
PSA		 Datum:
02.08.2018 08:46:37		 Views:
1187		 Rating:
     
Antwort:
 Nein
Thema:
Dartsspiel

Hallo zusammen,

ich habe in den letzten Tagen über den Worksheet_change-Trigger ein kleines Dartsspiel gebaut (also die Tabelle zum Eintragen, die Scheibe braucht man natürlich noch). Hierbei bin ich am überlegen, über eine Checkbox die Auswahlmöglichkeit von Double- bzw. Tripple-Out zu bauen. Da kommt mir natürlich der "Mod"-Befehl in den Sinn, nur komme ich aktuell nicht darauf, wie ich das in meine aktuelle Funktion integrieren kann. 

Hier der bisherige Code:

?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
Option Compare Text
Private del As Boolean
Private Sub worksheet_change(ByVal Target As Range)
With ThisWorkbook.Sheets("Darts")
    If Not del Then     'Delete-Modus für Datenentfernung
        If Target.Value = "DEL" Then    'Aktivierung des Delete-Modus durch eingabe von DEL
         
            del = True  'Delete-Modus activated
             
            Target.Value = ""
            .Copy After:=Sheets(1)
            Sheets(2).Name = "Game " & Format(Now(), "hh.nn, dd.mm.yyyy")
             
            If Sheets.Count > 10 Then
                Application.DisplayAlerts = False
                Sheets(11).Delete
                Application.DisplayAlerts = True
            End If
             
            .Activate
             
            'Daten werden entfernt
            .Range("A6:H" & .Rows.Count).Value = ""
            .Range("B5").Value = ""
            .Range("D5").Value = ""
            .Range("F5").Value = ""
            .Range("H5").Value = ""
            .Range("B5").Select
             
            del = False 'Delete-Modus deactivated
             
        ElseIf Target.Value = "SCORE" Then
             
            del = True
             
                .Range("M2:M100").Value = ""
                Target.Value = ""
                 
            del = False
             
        Else        'Bei normaler Eingabe
            If Target.row > 5 And Target.Column Mod 2 = 1 Then      'Wenn die Eingabe in einer passenden Spalte und _
                                                                     Reihe getätigt wurde
                Dim inte As Boolean         'Testet die Eingabe auf Integer-Tauglichkeit
                Dim r As Integer, c As Integer, t As Integer, todo As Integer   'Eingaben
                t = .Range("D1").Value   'Speichert den Wert für das Target (201, 301, 401, 501, etc.)
                r = Target.row          'Speichert die aktuelle Zeile
                c = Target.Column       'Speichert die aktuelle Spalte
                On Error GoTo falsch    'Sollte es kein Integer-tauglicher Wert sein
                    Dim v As Integer    'Speichert den eingegebenen Wert
                    v = Target.Value    'Integer-Wert wird eingelesen
                    inte = True         'Sollte es bis hierhin durchlaufen ist der Wert integer-tauglich
             
                If v >= 0 And v <= 60 Then  'Ist die Eingabe zwischen 0 und 60
             
                    If Target.row Mod 3 = 2 Then
             
                        If r = 8 Then
                            .Cells(r, c + 1).Value = t - .Cells(r - 2, c).Value - .Cells(r - 1, c).Value - .Cells(r, c).Value
                            .Cells(r - 1, c + 1).Value = (t - .Cells(r, c + 1).Value) / 3
                        Else
                            .Cells(r, c + 1).Value = .Cells(r - 3, c + 1).Value - .Cells(r - 2, c).Value - .Cells(r - 1, c).Value _
                                                    - .Cells(r, c).Value
                            .Cells(r - 1, c + 1).Value = (t - .Cells(r, c + 1).Value) / (r - 5)
                            If .Cells(r, c + 1).Value < 0 Then
                                MsgBox "Bust!"
                                todo = .Cells(r - 3, c + 1).Value
                                 
                                If todo - .Cells(r - 2, c).Value = 0 Then
                                    .Cells(r - 1, c).Value = 0
                                    .Cells(r, c).Value = 0
                                ElseIf todo - .Cells(r - 2, c).Value - .Cells(r - 1, c).Value = 0 Then
                                    .Cells(r, c).Value = 0
                                ElseIf todo - .Cells(r, c).Value - .Cells(r - 1, c).Value - .Cells(r - 2, c).Value < 0 Then
                                    .Cells(r - 2, c).Value = 0
                                    .Cells(r - 1, c).Value = 0
                                    .Cells(r, c).Value = 0
                                End If
             
                            ElseIf .Cells(r, c + 1).Value = 0 Then
                                MsgBox "Sieger: " & .Cells(5, c + 1).Value
                                 
                                Dim i As Integer
                                i = 2
                                While .Cells(i, 12).Value <> .Cells(5, c + 1).Value
                                     
                                    i = i + 1
                                     
                                Wend
                                 
                                .Cells(i, 13).Value = .Cells(i, 13).Value + 1
                                 
                                .Cells(1, 6).Value = "DEL"
                                 
                                Exit Sub
                            End If
                             
                             
                             
                        End If
             
                        .Cells(r - 2, c + 2).Select
             
                        r = r - 2
                        c = c + 2
             
                        If .Cells(5, c + 1) = "" Then
             
                            .Cells(r + 3, 1).Select
             
                        End If
             
                    End If
             
                Else
             
                        MsgBox "Sie können keine so hohe Zahl werfen!"
                        Target.Select
             
                End If
             
falsch:
             
                If Not inte Then
                    MsgBox "Bitte geben Sie nur Ganzzahlen ein!"
                    Target.Select
                End If
            End If
        End If
    End If
End With
End Sub

 

Wenn ihr Ideen für die Umsetzung habt, wäre das eine große Hilfe.

Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:
WYSIWYG-Editor, ctl00_Content_editor1



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
Rot Dartsspiel
 02.08.2018 08:46:37 PSA
Solved
02.08.2018 13:31:41 PSA
Solved