Inhalte von Zellen in definierten Felder bei Neueingabe verschieben

[eltoro]

Hallo zusammen,

ich habe folgendes Thema:

Ich würde gerne in einem definierten Bereich (zB A1:C3) Daten eingeben und dabei die bestehenden Daten in den Zellen nach folgender Logik verschieben lassen.

IST: 

A1: 1
A2: 2
A3: 3
B1: 4
B2: 5
B3: 6
C1: 7
C2: 8
C3: 9

Dann wird bei A3 ein neuer Wert eingegeben, zB 10 und die Tabelle soll dann wie folgt aussehen

A1: 1
A2: 2
A3: 10
B1: 3
B2: 4
B3: 5
C1: 6
C2: 7
C3: 8

und der Wert 9 soll in einen weiteren definierten Bereich verschoben werden (zB A6:C9)

die KI hat mir eine VBA Lösung vorgeschlagen, die hat aber Fehler gehabt und mein Problem nicht gelöst. Ich selbst kann leider nicht VBA programmieren.

Habt ihr eine Lösung?

[redeagle56]

Hallo,
wie wäre es mit einer Beispiel Tabelle?
In diese Tabelle trägst du händisch, die Ausgangslage
und dein Wunschergebnis ein.
Damit kann man dir eventuell helfen.

MfG Günter

[PetrolMaxxe]

sorry jetzt erst entdeckt, dass es 3 spaltig ist.

Gruß Uwe

[PetrolMaxxe]

Hallo,

so jetzt 3x3 spaltig.

  Zahlenspiel Spezial.xlsm (Größe: 18,81 KB / Downloads: 7)

Gruß Uwe

[UweD]

Hallo


- Rechtsclick auf den Tabellenblattreiter
- Code anzeigen
- Dort diesen Code einfügen

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Fehler
    Const APPNAME = "Worksheet_Change"
    Dim RNG1 As Range, Z, i As Long
    Dim RFArr(), Neuwert As Variant
    Set RNG1 = Range("A1:C3")
    RFArr = Array("A1", "A2", "A3", "B1", "B2", "B3", "C1", "C2", "C3", "A6", "A7", "A8", "B6", "B7", "B8", "C6", "C7", "C8")
    If Not Intersect(RNG1, Target) Is Nothing Then
        For Each Z In Target
            With Application
                Neuwert = Z.Value
                .EnableEvents = False
                .Undo

                For i = UBound(RFArr) To LBound(RFArr) + 1 Step -1
                    If Z.Address(False, False) <> RFArr(i) Then
                        Range(RFArr(i)).Value = Range(RFArr(i - 1)).Value
                    Else
                        Range(RFArr(i)).Value = Neuwert
                        Exit For
                    End If
                Next i
               
                ' Falls erste Position getroffen wurde:
                If Z.Address(False, False) = RFArr(LBound(RFArr)) Then
                    Range(RFArr(LBound(RFArr))).Value = Neuwert
                End If
                .EnableEvents = True
            End With
        Next
    End If
   
    '*** Fehlerbehandlung
    Err.Clear
Fehler:
    Application.EnableEvents = True
    If Err.Number <> 0 Then MsgBox "Fehler in Sub """ & APPNAME & """" & vbCrLf _
        & "Fehlernummer: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub

LG UweD

[eltoro]

Servus Uwe,

danke für den Code. Die Eingabe funktioniert grundsätzlich, aber wenn ich eine Zelle oder einen Bereich löschen möchte, wird der Bereich auch weitergeschoben.

Würdest du dir das bitte nochmals ansehen.

Danke!

lG

Mir ist gerade noch etwas aufgefallen. Wenn ich im ersten Bereich Daten eingebe, werden diese verschoben (auch in den zweiten Bereich hinein). Wenn ich jedoch im zweiten Beriech Daten eingebe, werden diese nicht verschoben.

[UweD]

Was soll geschehen, wenn die Zelle Leer ist und nun Inhalt bekommt?
Was, wenn die Zelle Inhalt hat und nun geleert wird?


den 2. Bereich kannst du so hinzufügen:

Code:

Set RNG1 = Range("A1:C3, A6:C8")

LG UweD

[eltoro]

wenn die Zelle leer ist, und ein Inhalt einfügt wird, dann soll der REst nicht verschoben werden, sondern einfach die Zelle gefüllt werden. Wenn die Zelle geleert wird, dann soll alles was danach ist, vorgezogen werden.

lG