dual linked cells across multiple worksheets

[Bill Martinez]

Hello,

I'm finishing up some code here that creates a dual link (when one cell is updated on one worksheet, another cell on another worksheet is updated AND vise versa). Moreover, there is a "Mapping" worksheet that contains all of the relationship links between the various cells on their corresponding worksheets. For example: On the mapping worksheet, Columns A and B contain mapping relationships between the "DS Subj" and "Elements" worksheets. Columns A and B are a pair, so are all of the successive pairs of columns after that. (e.g. Columns C and D contain mapping relationships between DS 1 and Elements worksheet (E & F are paired, along with G & H, I & J, etc.) I've attached an excel spreadsheet that contains the problem. For example worksheet "DS Subj" cell K29 is dual linked to worksheet "Elements" cell F4. (I've highlighted the cells that are supposed to be linked in yellow.)

The Problem: The code below works, but only for columns A & B. I cannot figure out why my other column pairs are not working. For example: worksheet "DS 1" cell L36 is supposed to be dual linked to worksheet "Elements" cell F5 (but it is not working). Here is the code, but again the file is attached:

Option Explicit

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
Dim ColIndex As Integer

ColIndex = 1
    With Worksheets("Mapping")  'Map contains the mapping relationships
        If ColIndex <= 31 Then
            Set ws1 = Worksheets(.Range(.Cells(1, ColIndex), .Cells(1, ColIndex)).Value)  'Take name of first worksheet from Mapping! Starting A1
            Set ws2 = Worksheets(.Range(.Cells(1, ColIndex + 1), .Cells(1, ColIndex + 1)).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, ColIndex), .Cells(65536, ColIndex + 1).End(xlUp))
        
            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 ColIndex + 1
                    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, ColIndex) <> "" Then
                            Set rg = ws1.Range(Map(i, ColIndex))
                            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, ColIndex + 1)).Cells(1, ColIndex).Offset(j, k).PasteSpecial xlPasteFormulas
                                cel.Copy ws2.Range(Map(i, ColIndex + 1)).Cells(1, ColIndex).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, ColIndex + 1) <> "" Then
                            Set rg = ws2.Range(Map(i, ColIndex + 1))
                            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, ColIndex)).Cells(1, ColIndex).Offset(j, k)
                                Application.CutCopyMode = True
                            End If
                        End If
                    Next i
                End Select
            Next cel
        ColIndex = ColIndex + 2
        End If
    End With

errhandler:
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

If you can help, I would greatly appreciate it.

Bill