Hallo Uwe, erst mal vielen Dank. Das sieht schon mal ganz gut aus, habe den Code jetzt komplett reinkopiert. Aber wenn ich die Datei öffne, dann passiert in der ersten Runde erst mal nichts. (es werden keine Werte übertragen) Ab der zweiten Runde überträgt er es fast so wie ich es wollte er beginnt es bei Spieler 1 nach P7 zu übertragen und bei Spieler 2 nach Q7 er müsste aber bei P8 oder Q8 anfangen. Sonnst müsste ich die anderen Tabellen umschreiben. Wenn die Datei bereits offen ist und man löscht alles dann dann überträgt er es gleich in der ersten Runde, allerdings auch nach P7 bzw Q7 Ist hoffentlich nur eine Kleinigkeit! Lade die Datei nochmal mit hoch. Noch mal vielen Dank, find ich ganz toll von euch das man hier Unterstützung erhält. Gruß Didi
Private Sub Worksheet_Change(ByVal Target As Range) Dim lngZ As Long With Target.Cells(1) If Not Application.Intersect(.Cells, Range("M7:O8")) Is Nothing Then Me.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, UserInterfaceOnly:=True lngZ = .Row + 9 'Umrechnung Eingabezeile in Ausgabespalte On Error Resume Next Application.EnableEvents = False Cells(Application.Max(8, Cells(Rows.Count, lngZ).End(xlUp).Row + 1), lngZ).Value = .Value Application.EnableEvents = True On Error GoTo 0 End If End With End Sub
Hallo Uwe, Es funktioniert solange richtig, solange die Eingabe im Gültigkeitsbereich bleibt. Gibt man mal eine andere als erlaubte Zahl ein kommt eine Fehlermeldung, das ist von mir auch so gewollt. Korrigiert man dann jetzt diese Eingabe, dann wird der jetzt gültige Wert gleich mehrmals übertragen. Wenn das noch behoben werden könnte, dann habt ihr einen tollen Job gemacht. Lade die Datei nochmal hoch, alle Werte die im Spielfeld (Links) schon Rot formatiert sind, sind aus dem Gültigkeitsbereich raus. Erstmal wieder vielen Dank für euer Bemühen. Gruß Didi
Mein Vorschlag: Entferne die Datenüberprüfung des Bereichs M7:O8 und probiere folgenden Code, in dem die Überprüfung nun mit drin ist:
Code:
Private Sub Worksheet_Change(ByVal Target As Range) Dim lngZ As Long With Target.Cells(1) If Not Application.Intersect(.Cells, Range("M7:O8")) Is Nothing Then Me.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, UserInterfaceOnly:=True lngZ = .Row + 9 'Umrechnung Eingabezeile in Ausgabespalte On Error Resume Next Application.EnableEvents = False If Len(.Value) Then If IsError(Application.Match(.Value, Cells(.Row + 4, 20).Resize(, 20), 0)) Then MsgBox "Eingabe nicht (mehr) erlaubt!", vbInformation + vbOKOnly Target.Select Else Cells(Application.Max(8, Cells(Rows.Count, lngZ).End(xlUp).Row + 1), lngZ).Value = .Value End If End If Application.EnableEvents = True On Error GoTo 0 End If End With End Sub
Gruß Uwe
(11.03.2021, 14:35)DartDidi schrieb: Wenn das noch behoben werden könnte, dann habt ihr einen tollen Job gemacht.
Hallo, Hurra!!! es scheint zu funktionieren. Werde es am Wochenende mit einem Kumpel testen. Habe eurem Kassenwart gerade eine mail geschickt. Werde euch dann eine Spende für euer Verein überweisen, ist versprochen sobald ich eure Daten habe. Nochmals vielen Dank an euch alle. Gruß Didi
Folgende(r) 1 Nutzer sagt Danke an DartDidi für diesen Beitrag:1 Nutzer sagt Danke an DartDidi für diesen Beitrag 28 • Kuwer
Nochmal Hallo, Tut mir echt leid, dass ich noch mal "störe". Es funktioniert alles bestens, so wie ich es wollte. Wäre es noch möglich mir einen Code zu schreiben, Wenn ich in Zelle M9 bin und Enter drücke das dann der Eingabebereich M7:O8 wieder gelöscht wird. Man kommt sonnst beim spielen durcheinander, weil man nicht sieht ob es die alten oder schon neuen Werte sind.
Hallo Uwe, habe nur den Code den ich von euch zuletzt erhalten habe reinkopiert Private Sub Worksheet_Change(ByVal Target As Range)
Dann habe ich beide Code zusammen probiert, also den alten und den neuen, passiert auch nichts. Ich mach erst mal Feierabend, vielleicht komme morgen drauf was gemeint ist. Gruß Didi
Private Sub Worksheet_Change(ByVal Target As Range) Dim lngZ As Long With Target.Cells(1) If Not Application.Intersect(.Cells, Range("M7:O8")) Is Nothing Then Me.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, UserInterfaceOnly:=True lngZ = .Row + 9 'Umrechnung Eingabezeile in Ausgabespalte On Error Resume Next Application.EnableEvents = False If Len(.Value) Then 'jetzt folgt die Gültigkeitsprüfung If IsError(Application.Match(.Value, Cells(.Row + 4, 20).Resize(, 20), 0)) Then MsgBox "Eingabe nicht (mehr) erlaubt!", vbInformation + vbOKOnly Target.Select Else Cells(Application.Max(8, Cells(Rows.Count, lngZ).End(xlUp).Row + 1), lngZ).Value = .Value End If End If Application.EnableEvents = True On Error GoTo 0 End If End With End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Static bolM9 As Boolean With Target.Cells() If .Address = "$M$9" Then If Application.WorksheetFunction.CountBlank(Range("M7:O8")) Then Application.EnableEvents = False Range("M7:O8").SpecialCells(xlCellTypeBlanks).Cells(1).Select Application.EnableEvents = True Else bolM9 = True End If Else If bolM9 Then bolM9 = False Me.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, UserInterfaceOnly:=True Range("M7:O8") = "" Range("M7").Select End If End If End With End Sub
Hallo Uwe, habe deinen letzten Code jetzt so reinkopiert, die Datei noch mal geschlossen und wieder geöffnet. Es funktioniert soweit alles richtig, aber die Werte in M7:O9 werden nicht gelöscht nur nach und nach überschrieben. Gruß Didi
Code zum Speichern der Werte ändern
![[-]](https://www.clever-excel-forum.de/images/collapse.png)