Lave relationer mellem flere celler

Her er første udgave:
- Marker de ønskede celler, der skal kædes sammen.
- Udfør Sub Test (gemmer adressen på de markerede celler)

- Indtast herefter en værdi i en af cellerne

Dette er jo ikke så effektivt - men jeg vender tilbage om lidt - således at man ikke manuelt skal udføre SUB Test.......

Koden anbringes i VBA - Ark1
============================
Dim rA As Variant, flag As Boolean
Sub test()
    rA = ActiveWindow.RangeSelection.Address
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If InStr(rA, Target.Address) > 0 And flag = False Then
        opdaterKæde Target.Address
    End If
End Sub
Private Sub opdaterKæde(adr)
Dim rX As Variant, v
    flag = True
    rX = rA
    v = Range(adr)
   
    While InStr(rX, ",") > 0
        p = InStr(rX, ",")
        If p > 0 Then
            del = Left(rX, p - 1)
            If del <> adr Then
                Range(del) = v
            End If
            rX = Mid(rX, p + 1)
        End If
    Wend
    flag = False
End Sub

Version 2
=========
Erstatter tidligere:
- multimarker de ønskede celler
- Højreklik i een af dem - de markerede celler gemmes
- indtast en værdi i een af dem

Dim rA As Variant, flag As Boolean
Sub gemMarkeredeCeller()
    rA = ActiveWindow.RangeSelection.Address
End Sub
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    gemMarkeredeCeller
    Cancel = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
    If InStr(rA, Target.Address) > 0 And flag = False Then
        opdaterKæde Target.Address
    End If
End Sub
Private Sub opdaterKæde(adr)
Dim rX As Variant, v
    flag = True
    rX = rA
    v = Range(adr)
   
    While InStr(rX, ",") > 0
        p = InStr(rX, ",")
        If p > 0 Then
            del = Left(rX, p - 1)
            If del <> adr Then
                Range(del) = v
            End If
            rX = Mid(rX, p + 1)
        End If
    Wend
    flag = False
End Sub

Det ser rigtig godt ud Supertekst.
Jeg har ikke mulighed for at teste det før senere, men smid lige et svar så jeg har mulighed for at give dig point'ene såfremt det virker.

Jeg går dermed ud fra at der ikke findes nogen anden løsning end VBA?!?

Det får du så.....

Et alternativ:
indsæt koden i arkets kodemodul (højreklik på fanen)
ret evt. sellerne til i de 2 linier.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B5, C10, E15, F20")) Is Nothing Then Exit Sub
Range("B5, C10, E15, F20") = Target
End Sub