Quad-linking cells VBA code

[xxY00700]

Hi there,

I am working on a piece of code to be able to quad-link cells (any change of any of the cells will be reflected in all the others, no matter where the change was made). To make it easier to use for those in the office who are not that comfortable in VBA, I used a skeleton format I found online that utilises cells in a separate worksheet (called 'Mapping'), where the first row is declaring sheet names and all cells below are representing the cells I want to link.

However, despite the code running (and desperately going through line by line for a fix) it is not working as intended- it appears only the first worksheet cells seem to be copied onto others. If anyone has any idea on what I have programmed incorrectly and any fix I would be massively appreciated.

My code:

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, ws3 As Worksheet, ws4 As Worksheet
    


    With Worksheets("Mapping")
        Set ws1 = Worksheets(.Range("A1").Value)
        Set ws2 = Worksheets(.Range("B1").Value)
        Set ws3 = Worksheets(.Range("C1").Value) 
        Set ws4 = Worksheets(.Range("D1").Value) 
        If Sh.Name <> ws1.Name And Sh.Name <> ws2.Name And Sh.Name <> ws3.Name And Sh.Name <> ws4.Name Then Exit Sub
        Map = Range(.Cells(2, 1), .Cells(65536, 4).End(xlUp))
    End With
    nRows = UBound(Map)
     
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    On Error GoTo errhandler
     
    For i = 1 To nRows
        For j = 1 To 4
            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 
                        j = cel.Row - rg.Row 
                        k = cel.Column - rg.Column                  
                        cel.Copy ws2.Range(Map(i, 2)).Cells(1, 1).Offset(j, k)
                        cel.Copy ws3.Range(Map(i, 3)).Cells(1, 1).Offset(j, k)
                        cel.Copy ws4.Range(Map(i, 4)).Cells(1, 1).Offset(j, k)
                        Application.CutCopyMode = True
                    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)
                        cel.Copy ws3.Range(Map(i, 3)).Cells(1, 1).Offset(j, k)
                        cel.Copy ws4.Range(Map(i, 4)).Cells(1, 1).Offset(j, k)
                        Application.CutCopyMode = True
                    End If
                End If
            Next i
        Case ws3.Name
            For i = 1 To nRows
                If Map(i, 3) <> "" Then
                    Set rg = ws3.Range(Map(i, 3))
                    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)
                        cel.Copy ws2.Range(Map(i, 2)).Cells(1, 1).Offset(j, k)
                        cel.Copy ws4.Range(Map(i, 4)).Cells(1, 1).Offset(j, k)
                        Application.CutCopyMode = True
                    End If
                End If
            Next i
        Case ws4.Name
            For i = 1 To nRows
                If Map(i, 4) <> "" Then
                    Set rg = ws4.Range(Map(i, 4))
                    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)
                        cel.Copy ws2.Range(Map(i, 2)).Cells(1, 1).Offset(j, k)
                        cel.Copy ws3.Range(Map(i, 3)).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