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?
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
sorry jetzt erst entdeckt, dass es 3 spaltig ist.
Gruß Uwe
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
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.
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
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