Relier les cellules

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not Intersect(Sheets("Feuil1").Range("$A$1"), Target) Is Nothing Then Feuil2.Range("B2") = Target.Value
Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not Intersect(Sheets("Feuil2").Range("$B$2"), Target) Is Nothing Then Feuil1.Range("A1") = Target.Value
Application.EnableEvents = True
End Sub

[SIZE=2]'Code de AV
Private Sub 
Worksheet_Change(ByVal Target As Excel.Range) 
If Intersect(Target, Range("zaza")) Is Nothing Then Exit Sub 
[zaza].Value = Target 
End Sub[/SIZE]

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim s As String, x As Range, Ligne As Long, n As Long

Ligne = Target.Row
Cancel = True

s = "Sélectionner une cellule de même valeur:"
On Error Resume Next
Do
  Set x = Nothing
  Set x = Application.InputBox(prompt:=s, Type:=8)
  If x Is Nothing Then
    Application.Goto Sheets("Idem").Cells(Ligne, 1)
    Exit Do
  ElseIf x.Parent.Name = "Idem" Then
    MsgBox "Erreur! la cellule ne doit pas se trouver sur la feuille 'Idem'"
  ElseIf x.Count <> 1 Then
    MsgBox "Erreur! ne sélectionner qu'une cellule à la fois"
  Else
    Sheets("Idem").Cells(Ligne, Columns.Count).End(xlToLeft).Offset(, 1).Formula = "='" & x.Parent.Name & "'!" & x.Address
  End If
Loop

End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim i As Long, j As Long, present As Boolean, x As Range, s As String

If Sh.Name = "Idem" Then Exit Sub
Application.EnableEvents = False
With Sheets("Idem")
  For i = 1 To .UsedRange.Rows.Count
    If Application.WorksheetFunction.CountA(.Rows(i)) <> 0 Then
      present = False
      For j = 1 To .Cells(i, Columns.Count).End(xlToLeft).Column
        If .Cells(i, j).HasFormula Then
          s = Mid(Replace(Split(.Cells(i, j).Formula, "!")(0), "!", ""), 2)
          Set x = Sheets(s).Range(Split(.Cells(i, j).Formula, "!")(1))
          If Sheets(s).Name = Sh.Name Then
            If Not Intersect(Target, x) Is Nothing Then
              present = True
              Exit For
            End If
          End If
        End If
      Next j
          
      If present Then
        For j = 1 To .Cells(i, Columns.Count).End(xlToLeft).Column
          If .Cells(i, j).HasFormula Then
            s = Mid(Replace(Split(.Cells(i, j).Formula, "!")(0), "!", ""), 2)
            Set x = Sheets(s).Range(Split(.Cells(i, j).Formula, "!")(1))
            x.Value = Target.Value
          End If
        Next j
      End If
    End If
  Next i
End With
Application.EnableEvents = True
End Sub