2 way cell linking - multiple cells and multiple sheets

[purple5621]

Hi All!

I am very new to VBA and working on a project that is way out of my league. I would really appreciate some help

I am trying to write a code that will allow 2-way entry between cells on many different sheets. I have been able to find some code that links multiple cells on one sheet to multiple cells on another sheet. But I am trying to link some cells from sheet1 to cells on sheet2 and then link different cells on sheet1 to cells on sheet3. I am hoping to link different cells on sheet1 to many different sheets in the workbook.


Here is what I am hoping to be able to do:

Sheet1 B4:P4 linked to Sheet2 C26:C41

Sheet1 B5:P5 linked to Sheet3 C:26:C41

Sheet1 B6:P6 linked to Sheet4 C26:C41

Sheet1 B7:P7 linked to Sheet5 C26:C41

.

.

Sheet1 B37:P37 linked to Sheet38 C26:C41

Thanks!

 

[offthelip]

Here is the code to do the first link (sheet1 B4 to P4 to Sheet 2 C26:C41 . you can do the other link by just copying the code and altering the ranges and the offsets
put this code in the sheet1 code:

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim tcell As Range
If Not (Intersect(Target, Range("B4:P4")) Is Nothing) Then
 For Each tcell In Target
    colno = tcell.Column
    With Worksheets("Sheet2")
    Application.EnableEvents = False
     .Range(.Cells(24 + colno, 3), .Cells(24 + colno, 3)) = tcell.Value
    Application.EnableEvents = True
    End With
 Next tcell
End If
End Sub

then put this code in sheet 2 code:

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim tcell As Range
If Not (Intersect(Target, Range("C26:C41")) Is Nothing) Then
 For Each tcell In Target
    rowno = tcell.Row
    With Worksheets("Sheet1")
    Application.EnableEvents = False
     .Range(.Cells(4, rowno - 24), .Cells(4, rowno - 24)) = tcell.Value
    Application.EnableEvents = True
    End With
 Next tcell
End If
End Sub

 

[shknbk2]

offtheclip's answer is great, but it got me thinking about generalizing the same sort of function so that you wouldn't have to update the code in every sheet.

My solution is kind of similar except I use a new linking sheet (called "Links") to identify the data that should be linked. Each row identifies the link back and forth between the sheets. Columns A and D are the sheet names and B-C are the start and end ranges on "Sheet2" that should be linked with the start and end ranges E-F of the sheets in column D.

(By the way, your B4:P4 range is 15 cells, while C26-C41 is 16 cells. I'm not sure which range is longer or shorter than needed. In my Links sheet, I went from B4 to Q4 so there would be 16 cells in each linked range.)

In a new module, I have the following code, which gets called by all of the linked sheets:

Sub LinkCells(ByVal T As Range, Sh As Worksheet)
    Dim searchCol As Integer
    Dim isectRange As Range
    Dim linkRange As Range
    Dim ofset As Integer
    Dim i As Integer
    
    With Sheets("Links")
        If Sh.Name = .Range("A1").Value Then
            searchCol = 1
            ofset = 3
        Else
            searchCol = 4
            ofset = -3
        End If
        For i = 1 To .Range("A1").CurrentRegion.Rows.Count
            Set isectRange = Sheets(.Cells(i, searchCol).Value).Range(.Cells(i, searchCol + 1).Value & ":" & .Cells(i, searchCol + 2).Value)
            If Not (Intersect(T, isectRange) Is Nothing) Then
                Set linkRange = Sheets(.Cells(i, searchCol).Offset(0, ofset).Value).Range(.Cells(i, searchCol + 1).Offset(0, ofset).Value & ":" & .Cells(i, searchCol + 2).Offset(0, ofset).Value)
                Application.EnableEvents = False
                linkRange.Value = WorksheetFunction.Transpose(isectRange.Value)
                Application.EnableEvents = True
                Exit For
            End If
        Next
    End With
End Sub

The reason for this is that you can now only need the following code in each linked sheet, and it doesn't need to change.

Private Sub Worksheet_Change(ByVal Target As Range)
    LinkCells Target, Me
End Sub

This worksheet code can get copied to each sheet's code. Plus, if you then copy the sheet later on, the code is already there and doesn't need to change.

The LinkCells code above checks to see if any of the cells in one of the linked ranges in any of the linked sheets is changed. If it is, it copies all linked cells to the other sheet. For example, if Sheet3.C27 is changed, C26:C41 is copied to Sheet2.B4:Q4. So any change to any linked cell copies all linked cells (the Transpose part) to make the code easier.

A version of my "Links" sheet is below to show an example.

Book1
	A	B	C	D	E	F
1	Sheet2	B4	Q4	Sheet3	C26	C41
2	Sheet2	B5	Q5	Sheet4	C26	C41
3	Sheet2	B6	Q6	Sheet5	C26	C41
4	Sheet2	B7	Q7	Sheet6	C26	C41
5	Sheet2	B8	Q8	Sheet7	C26	C41
6	Sheet2	B9	Q9	Sheet8	C26	C41
7	Sheet2	B10	Q10	Sheet9	C26	C41
Links

 

[purple5621]

Thank you both so much, this is amazing!


@shknbk2 I do have one follow-up question about your solution. I really like the idea of the 'links' sheets since it is way easier than modifying the code for each sheet. It was working great for me until I changed the names of some of the sheets in the workbook. I changed Sheet2 to "Salary Overview" and Sheet3 to "Main." I updated the sheet names on the Links tab, but I still got a range error when I entered a value into a cell on the Salary overview tab. Is there a way that I can use this code but also be able to change the tab names?

 

[shknbk2]

I changed the sheet names, and it works fine. If you debug the error, can you tell what the issue is?

Linked cells.xlsm
	A	B	C	D	E	F
1	Salary Overview	B4	Q4	Main	C26	C41
2	Salary Overview	B5	Q5	Sheet4	C26	C41
3	Salary Overview	B6	Q6	Sheet5	C26	C41
4	Salary Overview	B7	Q7	Sheet6	C26	C41
5	Salary Overview	B8	Q8	Sheet7	C26	C41
6	Salary Overview	B9	Q9	Sheet8	C26	C41
7	Salary Overview	B10	Q10	Sheet9	C26	C41
Links

Linked cells.xlsm
	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q
4	1	2	3	4	5	6	7	8	9	10	11	12	13	14	15	16
Salary Overview

Linked cells.xlsm
	C
26	1
27	2
28	3
29	4
30	5
31	6
32	7
33	8
34	9
35	10
36	11
37	12
38	13
39	14
40	15
41	16
Main

 

[mikerickson]

Another generalization approach.
If you want Sheet1!$A$1 linked with Sheet2!$B$2
Put Data validation on Sheet1!$A$1 with the formula =TRUE and the Error Title of Cell Link and the Error Message of Sheet2!$B$2
Then put this code in the ThisWorkbook code module

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim OtherCell As Range
    With Target
        If .Cells.Count = 1 Then
            If .Validation.ErrorTitle = "Cell Link" Then
                Set OtherCell = Range(.Validation.ErrorMessage)
            End If
        End If
    End With
    If Not OtherCell Is Nothing Then
    
        With OtherCell
            With .Validation
                .Delete
                .Add Type:=xlValidateCustom, AlertStyle:=xlValidAlertInformation, Operator:=xlBetween, Formula1:="=true"
                .ErrorTitle = "Cell Link"
                .ErrorMessage = Target.Address(, , , True)
            End With
            Application.EnableEvents = False
            .Value = Target.Value
            Application.EnableEvents = True
        End With
       
    End If
    
End Sub

Then copy that validation to any other cell you want paired and change the Error Message in each cell's validation to the address of the cell it is linked with.

 

[purple5621]

I changed the sheet names, and it works fine. If you debug the error, can you tell what the issue is?

Linked cells.xlsm
	A	B	C	D	E	F
1	Salary Overview	B4	Q4	Main	C26	C41
2	Salary Overview	B5	Q5	Sheet4	C26	C41
3	Salary Overview	B6	Q6	Sheet5	C26	C41
4	Salary Overview	B7	Q7	Sheet6	C26	C41
5	Salary Overview	B8	Q8	Sheet7	C26	C41
6	Salary Overview	B9	Q9	Sheet8	C26	C41
7	Salary Overview	B10	Q10	Sheet9	C26	C41
Links

Linked cells.xlsm
	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q
4	1	2	3	4	5	6	7	8	9	10	11	12	13	14	15	16
Salary Overview

Linked cells.xlsm
	C
26	1
27	2
28	3
29	4
30	5
31	6
32	7
33	8
34	9
35	10
36	11
37	12
38	13
39	14
40	15
41	16
Main

I just tried again and it worked this time. I don't know what I did wrong last time. Thanks!


One more question - it is possible that I will need to link some of the cells on Sheet1 to cells other than C26:C41. Can I do this? For example, I might need to link Sheet1 B5:P5 to Sheet2 Y33:Y48. I tried entering these values into the links sheets and seeing what happened. When I update values on Sheet1 B5:P5, they are reflected on Sheet2 Y33:Y48. However, if I try to update the values on Sheet2, I get the following message "Run-time error '1004' Method 'Intersect of Object'_Global' failed"


Is it possible for me to be able to link the values in Sheet1 to whatever cells I want on the other sheets by just entering the values into columns E&F on the ‘Links’ tab?

 

[shknbk2]

Is it possible for me to be able to link the values in Sheet1 to whatever cells I want on the other sheets by just entering the values into columns E&F on the ‘Links’ tab?

Yes, that was the intention of this method. I think once the new code is used below, it should work this way.

After researching a bit on the error you got, I found that you can't use Intersect with different sheets, which is what happens in the code. Best to first check to make sure they are on the same sheet. This code adds an If statement first to make sure the isectRange and T are on the same sheet If isectRange.Parent Is T.Parent Then. Replace your code with this.

Sub LinkCells(ByVal T As Range, Sh As Worksheet)
    Dim searchCol As Integer
    Dim isectRange As Range
    Dim linkRange As Range
    Dim ofset As Integer
    Dim i As Integer
    
    With Sheets("Links")
        If Sh.Name = .Range("A1").Value Then
            searchCol = 1
            ofset = 3
        Else
            searchCol = 4
            ofset = -3
        End If
        For i = 1 To .Range("A1").CurrentRegion.Rows.Count
            Set isectRange = Sheets(.Cells(i, searchCol).Value).Range(.Cells(i, searchCol + 1).Value & ":" & .Cells(i, searchCol + 2).Value)
            If isectRange.Parent Is T.Parent Then
                If Not (Intersect(T, isectRange) Is Nothing) Then
                    Set linkRange = Sheets(.Cells(i, searchCol).Offset(0, ofset).Value).Range(.Cells(i, searchCol + 1).Offset(0, ofset).Value & ":" & .Cells(i, searchCol + 2).Offset(0, ofset).Value)
                    Application.EnableEvents = False
                    linkRange.Value = WorksheetFunction.Transpose(isectRange.Value)
                    Application.EnableEvents = True
                    Exit For
                End If
            End If
        Next
    End With
End Sub

 

[AceDaMace]

Yes, that was the intention of this method. I think once the new code is used below, it should work this way.

After researching a bit on the error you got, I found that you can't use Intersect with different sheets, which is what happens in the code. Best to first check to make sure they are on the same sheet. This code adds an If statement first to make sure the isectRange and T are on the same sheet If isectRange.Parent Is T.Parent Then. Replace your code with this.

Sub LinkCells(ByVal T As Range, Sh As Worksheet)
    Dim searchCol As Integer
    Dim isectRange As Range
    Dim linkRange As Range
    Dim ofset As Integer
    Dim i As Integer
   
    With Sheets("Links")
        If Sh.Name = .Range("A1").Value Then
            searchCol = 1
            ofset = 3
        Else
            searchCol = 4
            ofset = -3
        End If
        For i = 1 To .Range("A1").CurrentRegion.Rows.Count
            Set isectRange = Sheets(.Cells(i, searchCol).Value).Range(.Cells(i, searchCol + 1).Value & ":" & .Cells(i, searchCol + 2).Value)
            If isectRange.Parent Is T.Parent Then
                If Not (Intersect(T, isectRange) Is Nothing) Then
                    Set linkRange = Sheets(.Cells(i, searchCol).Offset(0, ofset).Value).Range(.Cells(i, searchCol + 1).Offset(0, ofset).Value & ":" & .Cells(i, searchCol + 2).Offset(0, ofset).Value)
                    Application.EnableEvents = False
                    linkRange.Value = WorksheetFunction.Transpose(isectRange.Value)
                    Application.EnableEvents = True
                    Exit For
                End If
            End If
        Next
    End With
End Sub

Just found this, it is definitely great, thanks! But I was also curious what would you do or how would you change the code if you wanted the range of cells that are linked together both be spread out over either a range of rows or a range of columns. Since as the code is, it only works when one set is in a range of columns and the other set is in a range of rows. As if you do try to do them both using either-or, it just copies the first cell into the entire range and any data inputted to the other cells does not get copied over. Thanks!

 

[shknbk2]

I added an If block that checks to see if rows and columns are the same in both ranges or not. If the same, then no transpose is necessary. If the number of rows in one range equals the number of columns in the other range and vice versa, then transpose is necessary. If neither case is the same, then a message box indicates that the ranges don't have matching cells.

Sub LinkCells(ByVal T As Range, Sh As Worksheet)
    Dim searchCol As Integer
    Dim isectRange As Range
    Dim linkRange As Range
    Dim ofset As Integer
    Dim i As Integer
    
    With Sheets("Links")
        If Sh.Name = .Range("A1").Value Then
            searchCol = 1
            ofset = 3
        Else
            searchCol = 4
            ofset = -3
        End If
        For i = 1 To .Range("A1").CurrentRegion.Rows.Count
            Set isectRange = Sheets(.Cells(i, searchCol).Value).Range(.Cells(i, searchCol + 1).Value & ":" & .Cells(i, searchCol + 2).Value)
            If isectRange.Parent Is T.Parent Then
                If Not (Intersect(T, isectRange) Is Nothing) Then
                    Set linkRange = Sheets(.Cells(i, searchCol).Offset(0, ofset).Value).Range(.Cells(i, searchCol + 1).Offset(0, ofset).Value & ":" & .Cells(i, searchCol + 2).Offset(0, ofset).Value)
                    Application.EnableEvents = False
                    If linkRange.Columns.Count = isectRange.Columns.Count And linkRange.Rows.Count = isectRange.Rows.Count Then
                        linkRange.Value = isectRange.Value
                    ElseIf linkRange.Columns.Count = isectRange.Rows.Count And linkRange.Columns.Count = isectRange.Rows.Count Then
                        linkRange.Value = WorksheetFunction.Transpose(isectRange.Value)
                    Else
                        MsgBox "The linked ranges do not have matching cell counts. Nothing copied."
                    End If
                    Application.EnableEvents = True
                    Exit For
                End If
            End If
        Next
    End With
End Sub

This successfully works with these linked ranges:
Row 1: 1 row to 1 row
Row 2: 1 row to 1 column
Row 3: 2 rows to 2 columns

Linked cells.xlsm
	A	B	C	D	E	F
1	Salary Overview	B4	Q4	Main	B1	Q1
2	Salary Overview	B5	Q5	Sheet1	C26	C41
3	Salary Overview	B10	Q11	Main	C26	D41
Links