211 Aufrufe
Gefragt in Tabellenkalkulation von addeguddi Experte (2.5k Punkte)
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

1 Antwort

0 Punkte
Beantwortet von addeguddi Experte (2.5k Punkte)
Hallo wollte nur mitteilen, das ich es hinbekommen habe. Doch ein Problem bleibt bestehen, alles andere funktioniert. Habe ein Feld das sagt aus:  Letzten Wurf zurück nehmen hier geht ein kommt dann debuggen laufzeitfehler 1004 vielleicht kann man mir hier helfen?

'Anzahl Würfe verringern
Cells(arrRueck(0), arrRueck(1)) = Cells(arrRueck(0), arrRueck(1)).Value - 1

Gruß Adde
...