Relier les cellules

[Seiha]

Bonjour,

Je voudrais relier deux cellules de deux feuilles ensembles et je n'arrive pas à faire ce que je veux. En effet, je voudrais que pour la cellule A et B, si je change la valeur de A, la valeur de B change automatiquement aussi et vice versa si je change la valeur B, la valeur de A change automatiquement aussi.

Pourriez-vous m'aider?

Merci beaucoup.

Seiha

 

[mapomme]

Re : Relier les cellules

Bonjour Seiha,

Avec un peu de code VBA:

Dans le module de Feuil1:

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

Dans le module de Feuil2:

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

 

[piga25]

Re : Relier les cellules

Bonjour,
Peut comme ceci :
Toutes les cellules devant être liées sont nommées collectivement, par exemple "zaza". En cas de modification d'une des cellules de la zone, toutes les autres sont modifiées par la macro.

[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]

 

[Seiha]

Re : Relier les cellules

Bonjour,

Merci beaucoup pour la réponse. Pourtant, en fait je voudrais lier environ pour 20 cellules différentes de 16 feuilles ensemble. Donc ça me doit 20 x 16 de travail. Il n'y a pas d'autre moyen plus efficace?

Merci

Seiha

 

[mapomme]

Re : Relier les cellules

Bonjour Seiha,

J'ai bricolé quelque chose pour aider la saisie des cellules identiques et faire un code unique dans le module de 'ThisWorkbook'.

Saisie des adresses des cellules identiques
Cette saisie se fait dans la feuille ‘Idem’.
Chaque ligne comporte les adresses (sous forme de formule) des cellules devant toutes prendre la même valeur.

La saisie sous forme de formule permet le report automatique dans la feuille ‘Idem’ des changements de nom des feuilles ou des déplacements des cellules sources concernées. Le nom de la feuille 'Idem' ne doit pas être modifié.

Pour saisir les références des cellules de même valeur :

• Double-cliquer sur une ligne de la feuille ‘Idem’
• Une boite de dialogue s’ouvre
• Tout en gardant la boîte de dialogue ouverte, sélectionner la feuille puis la cellule concernée
• Cliquer sur OK
• Pour référencer la seconde cellule de même valeur, répétez l’opération.
• Quand vous avez saisi toutes les cellules de même valeur, cliquez sur annuler

Pour une autre série, double cliquez sur une autre ligne etc…

On peut par la suite rajouter des cellules à une ligne en réitérant les opérations ci-dessus.

La suppression d’une référence consiste à effacer la cellule correspondante (à la mano).

Sur une ligne, les formules peuvent être séparées par des cellules vides. Il peut exister des lignes vides entre des lignes remplies.

Le code de la feuille ‘Idem’ :

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

Le code dans le module de ‘ThisWorkbook’ :

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