Code zum Speichern der Werte ändern

[DartDidi]

Hallo,
wäre schön, wenn mir nochmal jemand für 2 Dinge behilflich sein könnte.
Füge am Ende mal einen Code ein der etwas bearbeitet werden müsste.
Ich versuche mal kurz zu erklären wie ich es bräuchte. (es soll mal ein Programm für Dart-Cricket werden)
So wie der Code jetzt ist werden die Eingaben für Spieler 1 (M7:O7) nach Spalte P8:P...... und die für Spieler 2 (M8:O8) nach Spalte Q8:Q... kopiert 
nachdem in Zelle M9 die Eingabetaste gedrückt wurde. (alle Werte werden zusammen übertragen)
Es sollte aber nach jeder Eingabe gleich der jeweilige Wert einzeln nacheinander übertragen werden, also der Wert von M7 nach Spalte P..., dann der Wert von N7 nach P..... 
und O7  nach P...  sowie  M8;N8und O8 jeweils nacheinander nach Spalte Q8....
In Zelle M9 sollen dann alle Eingaben in M7:O8 gelöscht werden damit es wieder von vorne los gehen kann.

Dann habe ich noch folgendes Problem zu lösen, damit das ganze Projekt auch richtig funktioniert.
Habe einen Bereich erstellt (T11:AN11) in dem für dieses Spiel die zulässigen Werte eingetragen sind, andere als diese Werte können nicht im Eingabebereich M7:O8 verwendet werden.
Diese Werte sollen jetzt so nach und nach unter bestimmten Bedingungen entfernt werden.
Wenn jetzt z.B. in AI3 eine 1 steht dann sollen die Werte in T11:V11 entfernt werden. ( das bedeutet alle Spieler haben das 15er Segment mindestens 3 mal getroffen, somit soll keine Eingabe der Werte 15;30;45 mehr möglich sein)
Wenn (AI5>2 und BC5>0) dann soll V11 (45) entfernt werden.
Da kommen aber noch so einige Bedingungen dazu, wäre schön da mal einen Code zu bekommen den ich dann auch selber nach meinen Bedürfnissen anpassen kann.

Hoffe es verständlich erklärt zu haben und bedanke mich schon mal für eure Unterstützung
Gruß Didi 

hier der Code der zu bearbeiten wäre und im Anhang das Projekt um das es mir geht

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Static bolM9 As Boolean
  With Target.Cells()
    If .Address = "$M$9" Then
      bolM9 = True
    Else
      If bolM9 Then
        bolM9 = False
        Me.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, UserInterfaceOnly:=True
        If Application.WorksheetFunction.CountBlank(Range("M7:O8")) Then
          MsgBox "Da fehlt noch was!"
          Application.EnableEvents = False
          Range("M7:O8").SpecialCells(xlCellTypeBlanks).Cells(1).Select
          Application.EnableEvents = True
        Else
          With Cells(Application.Max(7, Cells(Rows.Count, 16).End(xlUp).Row), 16)
            .Offset(1, 0).Value = Range("M7").Value
            .Offset(2, 0).Value = Range("N7").Value
            .Offset(3, 0).Value = Range("O7").Value
            .Offset(1, 1).Value = Range("M8").Value
            .Offset(2, 1).Value = Range("N8").Value
            .Offset(3, 1).Value = Range("O8").Value
          End With
          Range("M7:O8") = ""
          Range("M7").Select
        End If
      End If
    End If
  End With
End Sub

[schauan]

Hallöchen,

die Übertragung könntest Du z.B. mit

Target.Offset(0,3).Value = Target.Value

handeln. Musst nur den Target auf die Eingabezellen beschränken.

[DartDidi]

Hallo,
vielen Dank für dein bemühen, bin damit jetzt bisschen überfordert wie du das meinst.
überall wo .Offset steht Target davor und das =Range löschen???

 With Cells(Application.Max(7, Cells(Rows.Count, 16).End(xlUp).Row), 16)
          Target.Offset(1, 0).Value = Target("M7").Value
            Target.Offset(2, 0).Value = Target("N7").Value
            Target.Offset(3, 0).Value = Target("O7").Value
            Target.Offset(1, 1).Value = Target("M8").Value
            Target.Offset(2, 1).Value = Target("N8").Value
            Target.Offset(3, 1).Value = Target("O8").Value
          End With


hab das jetzt mal so probiert, aber da passiert jetzt nichts mehr, wie meinst du es genau???

Gruß Didi

[schauan]

Hallöchen,

probier die Funktionsweise erst mal an einem leeren Blatt aus.

Du hast ein Ereignismakro
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Selbiges wird bei Änderung der Zellauswahl ausgelöst. Du willst auf eine Eingabe reagieren. Dazu benötigst Du das
Private Sub Worksheet_Change(ByVal Target As Range)

Target ist die Zelle, wo Du etwas eingegeben hast. Das soll 3 Spalten nach rechts übertragen werden - lt. Deiner Beschreibung z.B. von M nach P
Und - Du willst auf jede Eingabe einzeln reagieren.

Entsprechend wäre die Schreibweise
Target.Offset(0, 3).Value = Target.Value

Jetzt käme noch die Eingrenzung hinzu, z.B.
If Target.Column < 13 Or target.Column > 15 Then Exit Sub

komplett dann in etwa so:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column < 13 Or target.Column > 15 Then Exit Sub
Target.Offset(0, 3).Value = Target.Value
End Sub

Man könnte auch noch den Zeilenbereich eingrenzen, und/oder das Übertragen nur ausführen, wenn nur eine einzelne Zelle geändert wird, und/oder ...

[DartDidi]

Hallo,
hoffe das ich euch nicht all zu sehr nerven tue.
Habe mit Excel schon so einiges gemacht, aber mit diesen VBA Codes da bin ich noch blutiger Anfänger.
Den Code hat mir Kuwer (Uwe) so geschrieben, war auch erstmal völlig Richtig so und hat so auch funktioniert.
Ich weiß auch nicht wie und wo ich da was Eingrenzen muss Warum <13 .... >15 ??? 
Jetzt käme noch die Eingrenzung hinzu, z.B.
If Target.Column < 13 Or target.Column > 15 Then Exit Sub

das andere habe ich selber hinbekommen, hab für jeden Spieler einen eigenen Gültigkeitsbereich erstellt, der je nach Bedingung dann jeweils verkleinert wird.
Jetzt liegt es nur noch an diesen Code der geändert werden müsste, damit mein Projekt hoffentlich dann auch funktioniert.
Danke für eure Geduld mit mir 
Gruß Didi
    

[schauan]

Hallöchen,

wenn Du diese Eingrenzung nicht machst und änderst z.B. was in Spalte J, wird Dir das nach M übertragen.
Außerdem würde das Makro dann immer weiter laufen, das was gerade von J nach M übertragen wurde, kommt nach O, dann von O nach R usw.

Du hast also 2 Probleme - zum einen die Übertragung aus einer "falschen" Spalte und zum anderen der "Dauerlauf"

Gegen den Dauerlauf kann man übrigens auch die Events abschalten

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
'Events stoppen
Application.EnableEvents = False
'Wenn die Spalte <13 (M) oder groesser 15 (O) ist, dann Makro verlassen
If Target.Column < 13 Or target.Column > 15 Then Exit Sub
'Wert nach rechts, 3 Spalten daneben uebertragen
Target.Offset(0, 3).Value = Target.Value
'Events aktivieren
Application.EnableEvents = True
End Sub

[Kuwer]

Hallo Didi,

lösche alles aus dem Modul der Tabelle und ersetze es mit folgenden Codes:

Code:

Option Explicit

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
      lngZ = .Row + 9 'Umrechnung Eingabezeile in Ausgabespalte
      On Error Resume Next
      Application.EnableEvents = False
      Cells(Application.Max(7, Cells(Rows.Count, lngZ).End(xlUp).Row + 1), lngZ).Value = .Value
      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
      bolM9 = True
    Else
      If bolM9 Then
        bolM9 = False
        Me.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, UserInterfaceOnly:=True
        If Application.WorksheetFunction.CountBlank(Range("M7:O8")) Then
          MsgBox "Da fehlt noch was!"
          Application.EnableEvents = False
          Range("M7:O8").SpecialCells(xlCellTypeBlanks).Cells(1).Select
          Application.EnableEvents = True
        Else
'          With Cells(Application.Max(7, Cells(Rows.Count, 16).End(xlUp).Row), 16)
'            .Offset(1, 0).Value = Range("M7").Value
'            .Offset(2, 0).Value = Range("N7").Value
'            .Offset(3, 0).Value = Range("O7").Value
'            .Offset(1, 1).Value = Range("M8").Value
'            .Offset(2, 1).Value = Range("N8").Value
'            .Offset(3, 1).Value = Range("O8").Value
'          End With
          Range("M7:O8") = ""
          Range("M7").Select
        End If
      End If
    End If
  End With
End Sub

Gruß Uwe

PS: Die Leerzeilen im Code werden (leider, auch ohne Vorschau,) durch die Forensoftware erzeugt.

[RPP63]

Hi Uwe!
Hihi! Das ist ein Feature, das aber nicht immer bei allen funktioniert. 

Do you remember?
https://www.clever-excel-forum.de/Thread...im-Beitrag

Gruß Ralf

[schauan]

Hallöchen,

in dem Fall liegt es an den pre-Tags der Code-Jeanie. Ohne selbige passt es.

[Kuwer]

Hi André,

in dem Fall liegt es an den pre-Tags der Code-Jeanie. Ohne selbige passt es.

ja wie jetzt, funktioniert dieses Feature jetzt bei Dir auch?

Gruß Uwe