324 Aufrufe
Gefragt in Tabellenkalkulation von addeguddi Experte (2.7k Punkte)
Hallo und einen schönen Tag an das Expertenteam.

Vielleicht kann mir jemand behilflich sein! Habe überall gestöbert , doch das passende VBA nicht gefunden, da es um VBA geht und ich weiß leider nicht wie ich das umsetzen kann.

Suche eine Lösung: die mir folgendes Gibt:

Wenn in Zelle J1 eine Ungerade Zahl steht (1,3,.5, usw.  sollen die Zellen C1 Bis D11 gesperrt werden.

Wenn In Zelle J1 eine gerade Zahl steht 0,2,4 usw. sollen die Zellen a1 bis c11 gesperrt werden.

Vielleicht ist jemand so nett und kann mir das lösen.

Habe in meinem Tabellenblatt so viel Formeln, dass das ewig dauert bis die Eingabe reagiert, daher suche ich nach einer VBA Lösung.

Für Hilfe bin ich im voraus sehr dankbar.

Gruß Adde

11 Antworten

+1 Punkt
Beantwortet von beverly_ Experte (3.4k Punkte)

Hi,

vielleicht hilft dir dies als Ansatz:

    If Range("J1") Mod 2 = 0 Then
        MsgBox "gerade Zahl"
    Else
        MsgBox "ungerade Zahl"
    End If

Bis später, Karin

0 Punkte
Beantwortet von addeguddi Experte (2.7k Punkte)
Vielen lieben Dank für deine Antwort und die Mühe die du dir gemacht hast.

Leider ist es nicht das was ich gerne hätte. Bei dieser Eingabe zeigt er mir nach jedem Klick an das es eine gerade oder ungerade Zahl ist. Möchte das bestimmte Zellen gesperrt werden wie ich oben in meiner Frage erwähnt habe

Vielleicht kannst du das so ändern das die besagten Zellen gesperrt werden.

Gruß Adde
+1 Punkt
Beantwortet von
Zuerst solltest Du alle Zellen markieren und unter Formatieren Gesperrt nicht setzen
Danach sollte es hiermit gehen (in etwa)
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$J$1" Then
    ActiveSheet.Unprotect
     If Range("J1") Mod 2 = 0 Then
        Range("A1:B11").Select
        Selection.Locked = True
        Range("C1:D11").Select
        Selection.Locked = False
     Else
        Range("A1:B11").Select
        Selection.Locked = False
        Range("C1:D11").Select
        Selection.Locked = True
     End If
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    ActiveSheet.EnableSelection = xlUnlockedCells
End If
End Sub
(in J1 sollte aber jedenfalls eine Zahl stehen oder der code wird abbrechen)
0 Punkte
Beantwortet von addeguddi Experte (2.7k Punkte)
Guten morgen Anonym,

vielen Dank für deine Hilfe. Habe es übernommen. doch auch hier bleibt es so als hätte ich es nicht.

Kann es daran liegen, dass in J1 eine Formel hinterlegt ist, die sich automatisch nach einer gewissen Eingabe die Zahl verändert ?

Dann kommt Fehlermeldung: Fehler beim Kompilieren Sub oder Function nicht definiert- und das Wenn ist blau Privat Sub gelb gekennzeichnet.

Gruß Adde.

Soll ich die Datei Hochladen?.
+1 Punkt
Beantwortet von
Ja bei einer Formel funktioniert der Code nicht, denn der nimmt das Ereignis, dass eine Zelle verändert wird

in deinem Fall müsste man wohl eher

Private Sub Worksheet_Calculate()
    ActiveSheet.Unprotect
     If Range("J1") Mod 2 = 0 Then
        Range("A1:B11").Select
        Selection.Locked = True
        Range("C1:D11").Select
        Selection.Locked = False
     Else
        Range("A1:B11").Select
        Selection.Locked = False
        Range("C1:D11").Select
        Selection.Locked = True
     End If
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    ActiveSheet.EnableSelection = xlUnlockedCells
End Sub

nehmen , was leider viel öfter laufen wird und eventuell die Datei langsamer macht

Warum es abbricht ist mir allerdings ein Rätsel

Hast Du den Code im VBA in das Tabellenblatt kopiert (nicht in ein Modul !)  ?

Ansonsten könnte es wohl nur an der Excel Version liegen, dass "ihm" irgendein Teil davon nicht gefällt - das ließe sich am leichtesten herausfinden indem man nach der Reihe Zeilen entfernt (da der Code überschaubbar ist)
0 Punkte
Beantwortet von addeguddi Experte (2.7k Punkte)
Bearbeitet von addeguddi

Hallo und guten morgen Anonym,

erst einmal vielen lieben Dank für deine Mühe und Geduld die du aufbringst.

Möchte ein mal kurz das Spiel erklären:

In den Zellen A2:B11 und C2:D11 stehen zahlen und in J1 ist eine Formel hinterlegt die sich automatisch verändert und zwar nach jedem 3ten Doppelklick. Wenn ich nun in Zelle A2, A3 und A4 per Doppelklick klicke wird die Zahl für Runde 1 in J1 für die 1 in 2 umgewandelt, dann sollen die Zellen von A2:b11 gesperrt werden. Nun beginnt das gleiche mit den den Zellen C2, C3 und C4 nach dem 3ten Doppelklick ändert sich die Zahl in J1 aus 2 in 1. Kurz gesagt, nach jedem 3ten DK. ändert sich die Zahl. Für jede Runde ädert sich die Zahl in J1 2te Runde 3 und 4 Usw.

Jetzt zu deiner Lösung und Frage:

Habe deinen Vorschlag in ein Modul eingefügt und folgendes passiert: Wenn in J1 die 1 Steht sind die Zellen C2:C11 gesperrt so wie es sein soll doch nachdem sich die Zahl in J1 aus 1 die 2 wird sind die Zellen weiterhin gesperrt und ich kann in keine Eingabe tätigen.

Kannst wenn du möchtest noch mal nachschauen. 

Gruß Adde

Ps. wenn ich dann auf die Zelle C2 klicke erscheint diese Fehlermeldung im Blatt vom Spiel   'falls kein Fehlwurf
      lngWurf = Target.Value und ist gelb 

0 Punkte
Beantwortet von addeguddi Experte (2.7k Punkte)
Hallo Anonyme

Habe deinen Vorschlag in einem leerem Tabellenblatt als Test  angelegt da funktioniert das. Nun denke ich, dass das an dem VBA liegt das vorhanden ist, denn hier kommt immer eine Fehlermeldung und ich weiß nicht was ich da machen soll. Du hast eine tolle Lösung erstellt. Kannst du mir einen Rat geben?

Gruß Adde
0 Punkte
Beantwortet von

Das klingt in der Tat nach 2 VBA Ereignissen, die sich "beißen"  - kannst Du mal den ganzen Inhalt des VBA Modules oder zumindest den Teil in dem 

lngWurf = Target.Value

vorkommt posten

(den den teil der J1 erhöht vlt kann man sich da noch einfacher dran hängen)

0 Punkte
Beantwortet von addeguddi Experte (2.7k Punkte)
Bearbeitet von addeguddi
Hallo Anonym,

was hältst du davon wenn ich dir meine Datei zukommen lasse? Denke dass du damit besser sehen kannst wo was ist. Das ist der Link. Noch ein kurzer Hinweis: J1 ändert sich nach 3 Würfe.

https://filehorst.de/d/eepvlgso

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 K19 bis d12 ausführen

If Intersect(Target, Range("i3, J3, A2:D11")) Is Nothing Then Exit Sub

'nicht in Zelle klicken

Cancel = True

'Bei Klick in I2 = Game on - Ansage starten

If Target.Address = "$I$3" Then

  lngAnsage = 998

  'Ansage starten

  Start_Ansage (lngAnsage)

  'dann Makro wieder verlassen

  Exit Sub

End If

'Nummer des Spielers einlesen

lngSpieler = Range("j1").Value

'Spalte für Spieler ermitteln; Spieler stehen in Spalten K bis RB

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 = "$f$12:$g$12" Then lngWurf = 25

    If Target.Address = "$f$12:$g$12" Then

         lngWurf = 50        '50 Zuweisen

         lngDT = 2           'Marker für Doppel setzen

    End If

         'prüfen, ob Fehlwurf

    If Target.Address = "$e$12:$f$12" 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 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

'Zeile für Würfe suchen

'dazu die Nr des Spielers herausfinden und damit Suchstring erstellen

strSpiel = "Sp" & Range("J1")

'Zeile für Spiel suchen

For lngZeile = 19 To 442

  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, 2).Value / 3, 0)

  

'Spalte für den Eintrag der Würfe ermitteln

lngWSpalte = WorksheetFunction.RoundDown(Cells(lngSZeile, 2).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, 2) = Cells(lngSZeile, 2).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

'Rest aus Anzahl der Würfe ermitteln und dann ent

Select Case Cells(lngSZeile, 2).Value Mod 3

  Case Is = 0

    'kein Rest, also 3. Wurf

    Cells(lngWZeile, lngSpalte + 2) = lngWurf

  Case Is = 1

    'Rest 1, also 1. Wurf

    Cells(lngWZeile, lngSpalte) = lngWurf

  Case Is = 2

    'Rest 2, also 2. Wurf

     Cells(lngWZeile, lngSpalte + 1) = lngWurf

 End Select

'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

'Ansage Wurfergebnis

Start_Ansage (lngWurf)

'Checkout; 9991 = Game over

If Range("J15").Value = 210 Then Start_Ansage (9991)

ActiveSheet.Protect

End Sub

Gruß Adde
+1 Punkt
Beantwortet von

Hallo Adde,

fürchte ich habe eben gelernt was andere leiden müssen wenn sie von mir größere Dateien bekommen ;)

ist leider nicht so gaaaanz einfach sich in dem Riesending zurecht zu finden, wenn man's nicht selbst entworfen hat ;)

Ich glaube aber ich habe die Stelle gefunden an der man es einsetzten könnte

'Anzahl Würfe erhöhen
Cells(lngSZeile, 2) = Cells(lngSZeile, 2).Value + 1

Soweit ich verstehe , sobald hier 3 steht ändert sich J1, also könnte man direkt danach 

If Cells(lngSZeile, 2) = 3 Then

     If Range("J1") Mod 2 = 0 Then
        Range("A1:B11").Select
        Selection.Locked = True
        Range("C1:D11").Select
        Selection.Locked = False
     Else
        Range("A1:B11").Select
        Selection.Locked = False
        Range("C1:D11").Select
        Selection.Locked = True
     End If

End If

einfügen denke ich (und sonst wieder entfernen)

...