Inhalte von Zellen in definierten Felder bei Neueingabe verschieben

[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