Create cells mirroring each others

[Jaberdino]

Hi Huys,

Long time no see

Hope you are well!

I'm trying to write something some kind of a mirror between multiple cells.

Context: I have a dropdown of countries on five different sheets (the dropdown is the same on each sheet).
I want the user to be able to change the country on each sheet.
Of course, when the user change the country on one sheet, it should be changed on all other sheets.

So, I've been playing with the events, creating endless loops kind of crashing my excel.

For instance, in the basic case of two sheet. When inserting this for the sheet1:

Public Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range
    Set KeyCells = WorkSheets(1).Range("A1:A1")
    If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing AND Activesheet.name="Sheet1" Then
        WorkSheets(2).Range("A1:A1").value=WorkSheets(1).Range("A1:A1").value
    End If
End Sub

and an equivalent code for sheet2, then I have "not enough resource to display completely".

I can't find a way to say "if the cell change and then change the cells on the other sheets IIF you are on the active sheet". So it doesn't create endless loop, I guess.

Thanks a lot for your help

Cheers,
Jaberdino

 

[MickG]

Try this:-
Your Drop Down (validation List) in "A1" of each sheet.
NB:- This code needs to go in the "ThisWorkbook" Module :- See VBProject window on left of VB editer window

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim Sht As Worksheet
Application.EnableEvents = False
    If Target.Address(0, 0) = "A1" Then
        For Each Sht In Worksheets
            Sht.Range("A1") = Target
        Next Sht
    End If
Application.EnableEvents = True
End Sub

 

[TMShucks]

Option Explicit


Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range)


' note: this code goes in the Workbook Class module


Dim ws As Worksheet
Dim KeyCells As Range
Set KeyCells = Range("A1")


If Target.Cells.Count > 1 Then Exit Sub
If Intersect(KeyCells, Target) Is Nothing Then Exit Sub
'If Target.Value = "" Then Exit Sub


Application.EnableEvents = False
For Each ws In Worksheets
    ws.Range("A1").Value = Target.Value
Next 'ws
Application.EnableEvents = True


End Sub

 

[Jaberdino]

You guys are amazing!

Always impressed by the speed

By the way, would you know how to restruct this action to certain sheet, eg not all my sheet will have this drop down.

Say, I only want to this to be activated on sheet "Dashboard1", "Dashboard2", etc. but not on "DATA1", "DATA2", etc. ?

Thanks again

 

[MickG]

Try this:-
Add the sheets you want to Array

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim Sht As Variant
Application.EnableEvents = False
    If Target.Address(0, 0) = "A1" Then
        For Each Sht In Array("Dashboard1", "Dashboard2")
            Sheets(Sht).Range("A1") = Target
        Next Sht
    End If
Application.EnableEvents = True
End Sub

 

[TMShucks]

I think you need to check and include/exclude the sheets to be mirrored. This can be checked using sh.Name

Option Explicit


Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range)


' note: this code goes in the Workbook Class module
' I only want to this to be activated on sheet "Dashboard1", "Dashboard2", etc. but not on "DATA1", "DATA2", etc.


Dim ws As Worksheet
Dim KeyCells As Range
Set KeyCells = Range("A1")
Const sSheets As String = "Dashboard1,Dashboard2,Dashboard3"


' check sheet is one of those to be mirrored
If InStr(sSheets, sh.Name) = 0 Then Exit Sub


' exclusions
If Target.Cells.Count > 1 Then Exit Sub
If Intersect(KeyCells, Target) Is Nothing Then Exit Sub
'If Target.Value = "" Then Exit Sub


' make changes to mirrored sheets
Application.EnableEvents = False
For Each ws In Sheets(Split(sSheets, ","))
    ws.Range("A1").Value = Target.Value
Next 'ws
Application.EnableEvents = True


End Sub

 

[TMShucks]

@MickG: I think, as it stands, your code will mirror changes made to cell A1 on ANY sheet but only update Dashboard1 and Dashboard2

 

[MickG]

TMS , thanks for that:-
Here is an alternative

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim Sht As Variant
Application.EnableEvents = False
 If Target.Address(0, 0) = "A1" And Left(Target.Parent.Name, 9) = "Dashboard" Then
        For Each Sht In Array("Dashboard1", "Dashboard2")
            Sheets(Sht).Range("A1") = Target
        Next Sht
    End If
Application.EnableEvents = True
End Sub

 

[TMShucks]

@Mick: ditto ... and another variation on a theme:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim Sht As Variant
Const sDB As String = "Dashboard"


Application.EnableEvents = False
 If Target.Address(0, 0) = "A1" And Left(Sh.Name, Len(sDB)) = sDB Then
        For Each Sht In Array(sDB & 1, sDB & 2)
            Sheets(Sht).Range("A1") = Target
        Next Sht
    End If
Application.EnableEvents = True
End Sub

 

[Jaberdino]

Excellent, both working perfectly!


I didn't know about this
Target.Parent.Name

which is quite useful ha!

Thanks a lot, I'll play with this now
</pre>