Hallo M. O.
schicke dir zur Ansicht das VBA das in dem Registerblatt vorhanden ist. Ich denke das alles richtig ist. Den letzten Hinweis den du geschickt hast, habe ich geändert. Das beforedoublellick ist aus dem was du mir schon einmal erstellt hast.wenn ich das aus der Liste nehme berechnet er nichts mehr. Es ist toll wie du dich engagierst aber ich glaube, ich lass es wie jetzt ist ohne Ansage der Punkte. Du kannst deine Zeit bestimmt besser gestalten als nur für meinen Wunsch den Kopf zu zerbrechen.
Gruß Adde
'Funktion "SendMessage" deklarieren
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal Hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, _
ByVal lParam As Long) As Long
'Funktion "FindWindow" deklarieren
Private Declare PtrSafe Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Sub Start_Ansage(lngWurf As Long)
'Variablen deklarieren
Dim MediaPlayer As Variant
Dim strSounddatei As String
Dim strPfad As String
'Pfad, in der die Sounddateien liegen - Anpassen
strPfad = "C:\Users\Adolf\Musik\Wiedergebelisten\"
'Name der abzuspielenden Datei Ermittenln
strSounddatei = lngWurf & ".mp3"
'Mit einem Shell-Befehl den Mediaplayer aufrufen im Hintergrund und die
'Sounddatei abspielen
MediaPlayer = Shell("C:\Program Files (x86)\Windows Media Player\wmplayer.exe """ _
& strPfad & strSounddatei & """", vbHide)
End Sub
Sub Stop_Ansage()
'Funktionen "SendMessage" und "FindWindow" starten
SendMessage FindWindow(vbNullString, "Windows Media Player"), &H10, 0, 0
End Sub
Private Sub SpinButton1_Change()
If SpinButton1.Value < 1 Then SpinButton1.Value = ActiveSheet.Range("f1")
If SpinButton1.Value > ActiveSheet.Range("f1") 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 lngWurf As Long
Dim lngDT As Long
Dim strSpiel As String
Dim lngZeile As Long
Dim lngSZeile As Long
Dim lngWZeile As Long
Dim lngWSpalte As Long
'Nur bei Klick im Bereich von A4 bis F14 ausführen
If Intersect(Target, Range("A4:F15")) Is Nothing Then Exit Sub
'nicht in Zelle klicken
Cancel = True
'Nummer des Spielers einlesen
lngSpieler = Range("G1").Value
'Spalte für Spieler ermitteln; Spieler stehen in Spalten K bis AH
lngSpalte = 8 + lngSpieler * 3
'Prüfen ob Zelle verbunden ist
If Target.Cells.Count > 1 Then
'falls ja dann die entsprechenden Werte in Variable schreiben
If Target.Address = "$A$15:$B$15" Then lngWurf = 25
If Target.Address = "$C$15:$D$15" Then
lngWurf = 50 '50 Zuweisen
lngDT = 2 'Marker für Doppel setzen
End If
'prüfen, ob Fehlwurf
If Target.Address = "$E$14:$F$14" Then lngWurf = 0
Else
'falls kein Fehlwurf
lngWurf = Target.Value
If Target.Column = 2 Or Target.Column = 5 Then lngDT = 2 'Marker für Doppel setzen
If Target.Column = 3 Or Target.Column = 6 Then lngDT = 3 'Marker für Triple setzen
End If
'wenn Überworfen, dann Wurfergebnis auf Null setzen
If Cells(6, lngSpalte) - lngWurf < 0 Then lngWurf = 0
'Falls nur 1 übrigbleibt und damit kein Doppel-Out möglich ist, Wurf auf Null setzen
If Cells(6, lngSpalte) - lngWurf = 1 Then lngWurf = 0
'Fall kein Check-Out mit Doppel, dann Ergebnis des Wurfes auf Null setzen
If Cells(6, lngSpalte) - lngWurf = 0 And lngDT <> 2 Then lngWurf = 0
'Zeile für Würfe suchen
'dazu die Nr des Spielers herausfinden und damit Suchstring erstellen
strSpiel = "Sp" & Range("G1")
'Zeile für Spiel suchen
For lngZeile = 19 To 128
If Cells(lngZeile, 1).Value = strSpiel Then
lngSZeile = lngZeile
Exit For
End If
Next lngZeile
'Zeile für Eintrag der Würfe suchen
lngWZeile = 19 + WorksheetFunction.RoundDown(Cells(lngSZeile, 10).Value / 3, 0)
'Spalte für den Eintrag der Würfe ermitteln
lngWSpalte = WorksheetFunction.RoundDown(Cells(lngSZeile, 10).Value / 3, 0) + 2
'Anzahl Würfe erhöhen
Cells(lngSZeile, lngWSpalte) = Cells(lngSZeile, lngWSpalte).Value + 1
'Anzahl Doppel erhöhen
If lngDT = 2 Then Cells(11, lngSpalte + 1) = Cells(11, lngSpalte + 1).Value + 1
'Anzahl Triple erhöhen
If lngDT = 3 Then Cells(11, lngSpalte + 2) = Cells(11, lngSpalte + 2).Value + 1
'Würfe eintragen
Cells(lngWZeile, lngSpalte + Cells(lngSZeile, lngWSpalte).Value - 1) = lngWurf
'Daten für die Rücknahme des Wurfes in das Array schreiben
arrRueck(0) = lngSZeile 'Zeile für Eintrag des Wurfs
arrRueck(1) = lngWSpalte 'Spalte für Eintrag des Wurfs
arrRueck(2) = lngSpalte 'Spalte für Spieler
arrRueck(3) = lngWZeile 'Zeile für Ergebnis des Wurfs
arrRueck(4) = lngSpalte + Cells(lngSZeile, lngWSpalte).Value - 1 'Spalte für Ergebnis des Wurfes
arrRueck(5) = lngDT 'Doppel oder Triple
If lngWurf > 0 Then Start_Ansage (lngWurf)
End Sub