Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) 
    Dim Map As Variant, x As Variant 
    Dim i As Long, j As Long, k As Long, n As Long, nRows As Long 
    Dim cel As Range, rg As Range 
    Dim ws1 As Worksheet, ws2 As Worksheet 
     
    With Worksheets("Mapping") 'Map contains the mapping relationships
        Set ws1 = Worksheets(.Range("A1").Value) 'Take name of first worksheet from Mapping!A1
        Set ws2 = Worksheets(.Range("B1").Value) 'Take name of first worksheet from Mapping!B1
        If Sh.Name <> ws1.Name And Sh.Name <> ws2.Name Then Exit Sub 'Neither linked worksheet was changed--exit sub
        Map = Range(.Cells(2, 1), .Cells(65536, 2).End(xlUp)) 
    End With 
    nRows = UBound(Map) 'Number of mapping relationships in table
     
    Application.ScreenUpdating = False 'Turn off screenupdating so code runs faster and no flicker
    Application.EnableEvents = False 'Turn off events so this sub isn't called recursively
    On Error GoTo errhandler 'If a fatal error occurs, turn screen updating and events handling back on
     
    For i = 1 To nRows 'Remove workbook and worksheet name from the mapping table
        For j = 1 To 2 
            x = InStr(1, Map(i, j), ":") 
            If x = 0 Then 
                Map(i, j) = Range(Map(i, j)).Address 
            Else 
                Map(i, j) = Range(Left(Map(i, j), x - 1)).Address & ":" & Range(Mid(Map(i, j), x + 1)).Address 
            End If 
        Next j 
    Next i 
     
    For Each cel In Target 
        Select Case Sh.Name 
        Case ws1.Name 
            For i = 1 To nRows 
                If Map(i, 1) <> "" Then 
                    Set rg = ws1.Range(Map(i, 1)) 
                    If Not Intersect(rg, cel) Is Nothing Then 'Is cel contained in a mapped range?
                        j = cel.Row - rg.Row 'Number of rows cel is below start of mapped range
                        k = cel.Column - rg.Column 'Number of columns cel is to right of mapped range
                         'cel.Copy    'The PasteSpecial method preserves the relative relationship of formulas
                         'ws2.Range(Map(i, 2)).Cells(1, 1).Offset(j, k).PasteSpecial xlPasteFormulas
                        cel.Copy ws2.Range(Map(i, 2)).Cells(1, 1).Offset(j, k) 'Paste formats, values & formulas
                        Application.CutCopyMode = True 'Clear the clipboard
                    End If 
                End If 
            Next i 
        Case ws2.Name 
            For i = 1 To nRows 
                If Map(i, 2) <> "" Then 
                    Set rg = ws2.Range(Map(i, 2)) 
                    If Not Intersect(rg, cel) Is Nothing Then 
                        j = cel.Row - rg.Row 
                        k = cel.Column - rg.Column 
                         'cel.Copy
                         'ws1.Range(Map(i, 1)).Cells(1, 1).Offset(j, k).PasteSpecial xlPasteFormulas
                        cel.Copy ws1.Range(Map(i, 1)).Cells(1, 1).Offset(j, k) 
                        Application.CutCopyMode = True 
                    End If 
                End If 
            Next i 
        End Select 
    Next cel 
errhandler: 
    Application.ScreenUpdating = True 
    Application.EnableEvents = True 
End Sub