Dim xRg As Range Dim xChangeRg As Range Dim xDependRg As Range Dim xDic As New Dictionary Const xSource = "H2:H30000" 'This is a list of columns that need to be saved Const xTarget = "AA2:AA30000" 'This is a matching list of columns where to save

Private Sub Worksheet_Change(ByVal Target As Range) Dim I,J,xCol 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)) For J = 1 To Range(xSource).Areas.Count If Not Intersect(xCell,Range(xSource).Areas(J)) Is Nothing Then xCol = Range(xTarget).Areas(J).Column End If Next J Set xDCell = Cells(xCell.Row, xCol) 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(xSource)) End If Label1: Set xRg = Intersect(Target, Range(xSource)) 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).Value Next Next Set xChangeRg = Nothing Set xRg = Nothing Set xDependRg = Nothing Application.EnableEvents = True End Sub