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