Alten Zellwert sichern

Forumthread: Alten Zellwert sichern

16.03.2021 10:55:32

Dirk

Hallo Profis,
ich brauche mal wieder eure Hilfe.
Ich habe eine Tabelle mit insgesamt 3 Bereichen (gesamt 6 Spalten) in denen der vorherige Eintrag einer Zelle (Aktuell) in einer anderen Zelle (Vorher) übertragen wird.
Hierzu habe ich im Netz einen Code gefunden, der auch soweit funktioniert; allerdings nur für einen Bereich.
Wie muss ich den Code abändern, damit der Code auf 3 Bereiche funktioniert.
Die Datei ist eine Beispieldatei, die die Originaldatei abbildet.
https://www.herber.de/bbs/user/144835.xlsm
Danke im Voraus
Gruß
Dirk

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Alten Zellwert sichern

16.03.2021 11:05:20

Werner
AW: Alten Zellwert sichern

16.03.2021 14:25:37

Dirk
Gerne u. Danke für die Rückmeldung. o.w.T.

16.03.2021 14:31:32

Werner

AW: Alten Zellwert sichern

16.03.2021 11:05:20

Werner

Hallo,

Dim xRg As Range
Dim xChangeRg As Range
Dim xDependRg As Range
Dim xDic As New Dictionary
Private Sub Worksheet_Change(ByVal Target As Range)
Dim I As Long
Dim xCell As Range
Dim xDCell As Range
Dim xHeader As String
Dim xCommText As String
On Error Resume Next
Application.ScreenUpdating = False
Application.EnableEvents = False
xHeader = "Previous value :"
x = xDic.Keys
For I = 0 To UBound(xDic.Keys)
Set xCell = Range(xDic.Keys(I))
Set xDCell = Cells(xCell.Row, Target.Column + 1)
xDCell.Value = ""
xDCell.Value = xDic.Items(I)
Next
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim I, J As Long
Dim xRgArea As Range
On Error GoTo Label1
If Target.Count > 1 Then Exit Sub
Application.EnableEvents = False
Set xDependRg = Target.Dependents
If xDependRg Is Nothing Then GoTo Label1
If Not xDependRg Is Nothing Then
Set xDependRg = Intersect(xDependRg, Range("B:B,E:E,H:H"))
End If
Label1:
Set xRg = Intersect(Target, Range("B:B,E:E,H:H"))
If (Not xRg Is Nothing) And (Not xDependRg Is Nothing) Then
Set xChangeRg = Union(xRg, xDependRg)
ElseIf (xRg Is Nothing) And (Not xDependRg Is Nothing) Then
Set xChangeRg = xDependRg
ElseIf (Not xRg Is Nothing) And (xDependRg Is Nothing) Then
Set xChangeRg = xRg
Else
Application.EnableEvents = True
Exit Sub
End If
xDic.RemoveAll
For I = 1 To xChangeRg.Areas.Count
Set xRgArea = xChangeRg.Areas(I)
For J = 1 To xRgArea.Count
xDic.Add xRgArea(J).Address, xRgArea(J).Formula
Next
Next
Set xChangeRg = Nothing
Set xRg = Nothing
Set xDependRg = Nothing
Application.EnableEvents = True
End Sub

Gruß Werner

AW: Alten Zellwert sichern

16.03.2021 14:25:37

Dirk

Hallo Werner,
danke für die schnelle Bearbeitung. Die Welt kann manchmal so einfach sein. Hätte ich auch drauf kommen können.
Gruß
Dirk

Gerne u. Danke für die Rückmeldung. o.w.T.

16.03.2021 14:31:32

Werner

Beliebteste Forumthreads (12 Monate)

Forumthread: Alten Zellwert sichern

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread