VBA - nur Wert kopieren - Codeanpassung

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, 2)
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("C:C"))

End If

Label1:

Set xRg = Intersect(Target, Range("C:C"))

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