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, 13: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)