2 way entry - coding for multiple cells

[glad_ir]

Hi,

I wonder if I could get some help on this one please?

I am using the code below to allow 2 way entry between cells on two sheets in the same workbook, named SUMMARY and SET UP - e.g. the code allows entry in SUMMARY cell D97 to update SET UP cell H507 and vice versa. The code works well but I need to enter it over 300 times to achieve what I need. Is there a way I can code this more efficiently?

The linked cells come in blocks - e.g. SUMMARY cells D97,D98,D99,D100,D101,D102,D103 need to allow 2 way entry with SET UP cells H507,H510,H513,H516,H519,H522,H525

then the second block would be SUMMARY cells D197, D198, D199 having 2 way entry with SET UP cells H607,H610, H613.....

3rd block adds another 100 to the cell references on both sheets and so on. Hope I've explained it clearly enough

Code in the SUMMARY sheet

If Not Intersect(Target, Range("D97")) Is Nothing Then
  If Target = Range("D97") Then
    If Sheets("SET UP").Range("H507").Value <> Target.Value Then
      Sheets("SET UP").Range("H507").Value = Target.Value
    End If
  End If
    End If

    If Not Intersect(Target, Range("D98")) Is Nothing Then
  If Target = Range("D98") Then
    If Sheets("SET UP").Range("H510").Value <> Target.Value Then
      Sheets("SET UP").Range("H510").Value = Target.Value
    End If
  End If
    End If

and CODE in the SET UP sheet

If Not Intersect(Target, Range("H507")) Is Nothing Then
   If Target = Range("H507") Then
      Sheets("SUMMARY").Range("D97").Value = Target.Value
   End If
    End If

    If Not Intersect(Target, Range("H510")) Is Nothing Then
   If Target = Range("H510") Then
      Sheets("SUMMARY").Range("D98").Value = Target.Value
   End If
    End If

Any help or thoughts would be much appreciated.

Thank you,
Iain

 

[Akuini]

Hi, @glad_ir
Try this:
Please try this on a clean workbook first, with "Sheet1" & "Sheet2" in it, and if it works then you can change the code as needed in your workbook.

- I'm using "Sheet1" & "Sheet2", you may change it this part:
Sheets("Sheet2").Range(ary(i)).Value = Range(arx(i)).Value

Sheets("Sheet1").Range(arx(i)).Value = Range(ary(i)).Value

- Change the cells in question in this part, (you can have as many as you need):
arx = Split("A2,A3,A10,A11", ",")
ary = Split("C5,C6,C13,C14", ",")

Code in sheet1 module:

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo skip:

If Target.Cells.CountLarge > 1 Then Exit Sub
Dim arx, ary
    
    arx = Split("A2,A3,A10,A11", ",") 'cells in sheet1
    ary = Split("C5,C6,C13,C14", ",") 'cells in sheet2
    For i = 0 To UBound(arx)
        If Target.Address(0, 0) = arx(i) Then
        Application.EnableEvents = False
            Sheets("Sheet2").Range(ary(i)).Value = Range(arx(i)).Value
        Application.EnableEvents = True
        Exit For
        End If

    Next
    
Exit Sub
skip:
Application.EnableEvents = True
MsgBox "Error number " & Err.Number & " : " & Err.Description

End Sub

Code in sheet2 module:

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo skip:

If Target.Cells.CountLarge > 1 Then Exit Sub
Dim arx, ary
    arx = Split("A2,A3,A10,A11", ",") 'cells in sheet1
    ary = Split("C5,C6,C13,C14", ",") 'cells in sheet2
    For i = 0 To UBound(arx)
        If Target.Address(0, 0) = ary(i) Then
        Application.EnableEvents = False
            Sheets("Sheet1").Range(arx(i)).Value = Range(ary(i)).Value
        Application.EnableEvents = True
        Exit For
        End If

    Next
    

Exit Sub
skip:
Application.EnableEvents = True
MsgBox "Error number " & Err.Number & " : " & Err.Description

End Sub

 

[maabadi]

Or try these two code:
Sheet SUMMARY

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Skip:
If Not Intersect(Target, Union(Range("D97:D103"), Range("D197:D203"), Range("D297:D303"))) Is Nothing Then
    If Sheets("SET UP").Range("H" & 507 + (Target.Row - 97) * 3).Value <> Target.Value Then
      Application.EnableEvents = False
      Sheets("SET UP").Range("H" & 507 + (Target.Row - 97) * 3).Value = Target.Value
Skip:
      Application.EnableEvents = True
    End If
  End If
End Sub

Sheet SET UP

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Skip
If Not Intersect(Target, Union(Range("H507:H525"), Range("H607:H625"), Range("H707:H725"))) Is Nothing Then
    If Sheets("SUMMARY").Range("D" & 97 + (Target.Row - 507) / 3).Value <> Target.Value Then
      Application.EnableEvents = False
      Sheets("SUMMARY").Range("D" & 97 + (Target.Row - 507) / 3).Value = Target.Value
Skip:
      Application.EnableEvents = True
    End If
  End If
End Sub

 

[glad_ir]

Hi, thank you so much for replying. This works perfectly and will save me lots of time

 

[glad_ir]

So just spotted the earlier solution. Both of these work for me - thank you both so much. Really appreciate your help

 

[maabadi]

You're Welcome & Glad we can help.

 

[Akuini]

@glad_ir
You're welcome, glad to help & thanks for the feedback.
I forgot something, the code only works if you change one cell at a time. If you want to change multiple cells simultaneously (by copy-paste multiple cells) then we need different code.

 

[glad_ir]

@glad_ir
You're welcome, glad to help & thanks for the feedback.
I forgot something, the code only works if you change one cell at a time. If you want to change multiple cells simultaneously (by copy-paste multiple cells) then we need different code.

thank you.....much appreciated