Linking Cells From Two Worksheets - Advanced

[rzarx]

Hi I have been trying to link the cells from multiple worksheets
(for example 6) together. I am trying to use this article
hxxp://vbaexpress.com/kb/getarticle.php?kb_id=259 by byundt.

I have attempted to modify the code but it is not working as intended.

Basically it can do A-->B or C-->D but it can't do A-->B-->C-->D-->A etc.

I would like the code to be able to scale so I people can link as many worksheets together as required.

Below is my attempt at modifying byundt's code:


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, ws3 As Worksheet, ws4 As Worksheet, ws5 As Worksheet, ws6 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
Set ws3 = Worksheets(.Range("C1").Value) 'Take name of first worksheet from Mapping!A1
Set ws4 = Worksheets(.Range("D1").Value) 'Take name of first worksheet from Mapping!B1
Set ws5 = Worksheets(.Range("E1").Value) 'Take name of first worksheet from Mapping!A1
Set ws6 = Worksheets(.Range("F1").Value) 'Take name of first worksheet from Mapping!B1

If Sh.Name <> ws1.Name And Sh.Name <> ws2.Name And Sh.Name <> ws3.Name And Sh.Name <> ws4.Name And Sh.Name <> ws5.Name And Sh.Name <> ws6.Name Then Exit Sub 'Neither linked worksheet was changed--exit sub
Map = Range(.Cells(2, 1), .Cells(65536, 6).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 6
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 ws3.Range(Map(i, 3)).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).PasteSpecial xlPasteFormulas
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).PasteSpecial xlPasteFormulas
cel.Copy ws5.Range(Map(i, 5)).Cells(1, 1).Offset(j, k)
Application.CutCopyMode = True
End If
End If
Next i
Case ws5.Name
For i = 1 To nRows
If Map(i, 5) <> "" Then
Set rg = ws5.Range(Map(i, 5))
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 ws6.Range(Map(i, 6)).Cells(1, 1).Offset(j, k)
Application.CutCopyMode = True
End If
End If
Next i
Case ws6.Name
For i = 1 To nRows
If Map(i, 6) <> "" Then
Set rg = ws6.Range(Map(i, 6))
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