Hallo,
sitze leider wieder vor einem Problem. Versuche als ActiveSheet.Unprotect und ActiveSheet:protect in ein VBA einzufügen kriege laufend die Meldung debuggen. Ich weiß nicht ob ich das in jedes Makro und an welcher Stelle das eingefügt werden soll. Überall lese ich am Anfang und am Ende einsetzen. Ich Frage mich was ist der Anfang und was das Ende, da ich das nicht so richtig verstehe.. Vielleicht kann mir jemand das in das unten aufgeführte VBA einsetzen und mir mitteilt, wie oben genannt in jedes VBA einfügen muß.
Für Hilfe wäre ich dankbar.
Gruß Adde
Habe die Zellen, die nicht gesperrt werden sollen, markiert und nicht als gesperrte Zellen unter Blattschutz eingegeben.Diese Makros, mit Wurf zurück nehmen und ein Makro mit Alles löschen funktionieren nicht.
Das ist das Makro für dieser Tabelle
'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:\ProgramData\Dart2014\Sounds\"
'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()
ActiveSheet.Unprotect
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
ActiveSheet.Protect
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
ActiveSheet.Unprotect
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
Dim lngAnsage As Long
Dim bUeberw As Boolean
Dim i As Long
'Nur bei Klick im Bereich von IK2 bis IP12 ausführen
If Intersect(Target, Range("ie1", "ik2:ip12")) Is Nothing Then Exit Sub
'nicht in Zelle klicken
Cancel = True
'Bei Klick in IE1 = Game on - Ansage starten
If Target.Address = "$IE$1" Then
lngAnsage = 998
'Ansage starten
Start_Ansage (lngAnsage)
'dann Makro wieder verlassen
Exit Sub
End If
'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 = "$IK$12:$IL$12" Then lngWurf = 25
If Target.Address = "$IM$12:$IN$12" Then
lngWurf = 50 '50 Zuweisen
lngDT = 2 'Marker für Doppel setzen
End If
'prüfen, ob Fehlwurf
If Target.Address = "$io$12:$ip$12" Then lngWurf = 0
Else
'falls kein Fehlwurf
lngWurf = Target.Value
If Target.Column = 246 Or Target.Column = 249 Then lngDT = 2 'Marker für Doppel setzen
If Target.Column = 247 Or Target.Column = 250 Then lngDT = 3 'Marker für Triple setze
End If
'wenn Überworfen,
If Cells(6, lngSpalte) - lngWurf < 0 Then
'dann Wurfergebnis auf Null setzen
lngWurf = 0
'Marker für überworfen setzen
bUeberw = True
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 = 1 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
'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
'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
'hier für die Ansage und Anzeige
'prüfen ob Anzahl der Würfe ohne Rest durch 3 Teilbar ist oder Checkout vorliegt
If Cells(lngSZeile, lngWSpalte).Value Mod 3 = 0 And Cells(1, lngSpalte).Value <> "Checkout" Then
'Anzeige
Range("CH4") = "Geworfen: " & Cells(arrRueck(3), arrRueck(4)).Value + Cells(arrRueck(3), arrRueck(4) - 2) + Cells(arrRueck(3), arrRueck(4) - 1) & vbLf & "Rest: " & Cells(6, arrRueck(4) - 2).Value
lngAnsage = Cells(lngWZeile, lngSpalte + Cells(lngSZeile, lngWSpalte).Value - 1) + Cells(lngWZeile, lngSpalte + Cells(lngSZeile, lngWSpalte).Value - 2) + Cells(lngWZeile, lngSpalte + Cells(lngSZeile, lngWSpalte).Value - 3)
Start_Ansage (lngAnsage)
'Anzeige nach 5 Sekunden wieder löschen
Application.Wait Now + TimeValue("00:00:5")
Range("CH4") = ""
End If
'Checkout; 999 = Game over
If Cells(1, lngSpalte).Value = "Checkout" Then Start_Ansage (999)
End Sub
ActiveSheet.Protect