Code pour que certaines cellules aient toujours la même valeur

Le 09/03/2023 à 16:04

Bonjour,

Je ne sais absolument pas par quoi commencer, mes recherches n'ont rien donné car je ne sais pas de trop comment expliquer ma demande.

J'ai un tableau avec plusieurs feuilles, dans ces feuilles certaines cellules doivent être identiques entre elles. Je ne peux pas utiliser la simple formule "=" car je dois rester capable de modifier chaque cellule (et donc écraser la formule s'il y en à une).

Je pense donc qu'il faut passer par du VBA mais je n'ai rien trouver à ce sujet.

J'ai fournis un tableau en exemple en pièce jointe : les cellules vertes et rouges doivent être identique entre elles selon leur couleur respective.

Chacune de ces cellules doit pouvoir être modifiée et en la modifiant, les autres cellules doivent prendre cette valeur automatiquement...

Désolé pour ce tableau extrêmement vide mais je suis obligé pour des questions de confidentialité... Je pense pouvoir adapter le code si quelqu'un trouve une solution.

Merci d'avance à vous

10excel-vba.xlsm (12.98 Ko)

Le 09/03/2023 à 16:53

Bonjour

Ci joint ma solution

la macro est dans thisworkook

12excel-vba.xlsm (20.21 Ko)

A+ François

Le 10/03/2023 à 07:58

Bonjour,

Désolé pour la réponse tardive j'ai du attendre le lendemain pour tester ce code appliqué à mon vrai fichier au travail.

ça marche parfaitement !!! Je n'en comprends pas de trop le fonctionnement mais tout est comme je l'esperais.

(J'ai aussi copié la ligne présente sur chaque feuille en plus du code dans thisworkbook.)

Un grand merci !

Edit : je rencontre un nouveau problème lié à ce code (et plus particulièrement cette ligne) :

Le bug est rencontré à l'activation de ce code, ou même simple action "Copier" :

Sub Bouton_PS2() 'Envois de mail auto pour un lavage PS2
With Sheets("PS2")
Dim Commentaire As Variant
Reponse = Application.InputBox("Vérifiez de bien avoir :" & Chr(10) & "" & Chr(10) & "- Entré les deux numéros AGRO" & Chr(10) & "- Entré la date prévu dans le champ ci-dessous :" & Chr(10) & "- Ouvert l'application Outlook", Type:=2)

If VarType(Reponse) = vbBoolean Then
    MsgBox "Demande annulée"
    Else
Range("S1") = Reponse 'Cellule S1 contient le texte écris dans ma MsgBox, ne pas verrouiller la cellule
                Set MyApp = CreateObject("Outlook.Application") 'Outlook doit être ouvert
Set MyItem = MyApp.CreateItem(0)
With MyItem
    .To = "bug@excel.com"
    .CC = "bug@excel.com"
    .Subject = "Demande de référence couleur - PS2"
    .ReadReceiptRequested = False 'accusé de réception ?
sbody = "<html><body>Bonjour,<br><br>Merci de préparer la référence du " & Range("B7") & " (" & Range("D7") & ") vers le " & [K7] & " (" & [M7] & ") à " & [Q28] & " ppm sur la ligne PS2 pour le " & [S1] & ".<br><br>Bonne journée !</body></html>"

'plus bas
.htmlbody = sbody
End With
MyItem.Send 'Boite de dialogue de confirmation de l'envoi du mail
MsgBox "Demande envoyée." & Chr(10) & "" & Chr(10) & "Merci et bonne journée !"
End If
End With
End Sub

Le 10/03/2023 à 09:50

Désolé de faire un doublon mais je ne trouve pas la fonction "éditer" pour modifier mon message précédent.

Problème supplémentaire lié au code que vous avez écrit : Si je vide le contenu d'une des cellules concernées, le code plante aussi

Le 10/03/2023 à 11:26

J'ai mis ta nacro dans le module 1 (je ne l'ai pas testée)

J'ai mis en début de macro un ctrl=true. De ce fait ma macro n'est pas traitée

Ma macro ne gére que les cellules C4 et G4

Si tu fais un copié/collé d'autres cellules il n'y a pas de problème

15excel-vba.xlsm (23.02 Ko)

A+ François

Le 10/03/2023 à 11:40

Merci pour ton retour François,

Pour ce qui est de l'emplacement des cellules gérées, j'ai adapté aux bonnes cellules dans mon tableau (B7 et K7 en réalité)

En essayant la nouvelle version de ton code j'obtient désormais ce message en validant une entrée dans une des cellules concernées :

Je précise que je n'ai aucune autre macro hormis le module décris plus haut dans mon tableur

Le 10/03/2023 à 14:21

N'as tu pas oublié, en haut du module 1

Public ctrl As Boolean

A+ François

Le 14/03/2023 à 09:28

Bonjour, désolé pour la réponse tardive, je n'ai pas eu le temps de replonger dedans entre deux...

Pour le module, il fonctionne très bien si j'enlève le VBA qu'on essaye de mettre en place, en ajoutant "Public ctrl As Boolean" au début du code du module,

j'obtient l'erreur suivante dès que j'entre une valeur dans une cellule concernée par le code :

la mention "ctrl" (ligne 3) est surlignée suite à cette erreur

Le 14/03/2023 à 11:34

poste doublon encore une fois, désolé !

J'ai donc ajouté "Public ctrl As Boolean" au début du code situé dans thisworkbook et ça semble marcher pas trop mal !

Mais je rencontre toujours un petit problème, j'obtient la même erreur dans deux situations :

- des formules dans le tableur font appel à ces deux cellules (B7 et K7), une des cellules intervenant dans ces formules contient comme valeur soit "OUI" soit "NON" (liste de choix), j'obtient l'erreur en changeant cette valeur

- J'obtient aussi cette même erreur en activant le code du module qui envoie le mail automatiquement

Voici l'erreur en question :

Le 14/03/2023 à 13:26

Bonjour

J'ai réassayé je n'ai jamais d'erreur.

Envoie moi ton fichier

A+ François

Le 14/03/2023 à 13:31

Bonjour François, merci de ne pas perdre espoir avec moi !

C'est un document comprenant des données d'entreprise, rien de compromettant ou sensible mais j'aimerais éviter de le publier publiquement, puis-je te l'envois par message privé ? (tu sembles avoir désactivé les messages perso)

Je comprends bien que ce serait BEAUCOUP plus simple de voir directement le sujet ! (il y a des formules dans tout les sens...)

Edit : j'ai peut être une piste ! Je pense qu'actuellement le code s'applique à TOUTES les feuilles du document, or il faudrait qu'il s'applique uniquement à certaines feuilles (nommées : SC1, PS2, GR2, ACE, PS1, HB1, HB2 et Pack'R). Du fait qu'elle s'applique à toutes les feuilles certaines cellules sont remplacées aussi et faussent des formules, d'où l'erreur peut être ?

(vraiment, je m'excuse de rendre la chose certainement plus compliquée qu'elle ne l'est...)

Le 14/03/2023 à 15:33

Bon

J'aime pas qu'on se moque de moi.

Pas de macro dans thisworkbook

B7 et K7 sur SC1, PS2, GR2, ACE, PS1, HB1, HB2 et Pack'R...

Je n'ai qu"une feuille PS2 et les cellules B7 et K7 sont identique aux autres cellules de la même colonne...

Salut

Je laisse tomber

François

Le 14/03/2023 à 15:49

Etant surpris de votre réponse j'ai vérifié le fichier envoyé, je n'ai pas envoyé le bon fichier et je m'en excuse, j'ai envoyé une très vielle version.

Je vous ai envoyé le bon fichier cette fois-ci, mais je comprendrais votre abandon... Quoi qu'il en soit je ne me moque absolument pas de vous...

Le 15/03/2023 à 09:12

Un énorme merci à François pour ce code qui marche parfaitement ! Mon fichier étant plutôt confidentiel, je ne peux pas le poster ici mais voici le code ayant résolu mon problème : (ça pourra peut être en aider certains)

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
  Dim i As Integer, lig As Long, col As Integer, mavar
  If Target.Count > 1 Then Exit Sub
  If ctrl = True Or Target.Value = "" Then Exit Sub
  If Target.Address = "$B$7" Or Target.Address = "$K$7" Then
    lig = Target.Row: col = Target.Column: mavar = Target.Value: ctrl = True
  Else
  Exit Sub
  End If
  For i = 1 To Sheets.Count
    If Sheets(i).Name = "SC1" Or Sheets(i).Name = "PS2" Or Sheets(i).Name = "GR2" _
    Or Sheets(i).Name = "ACE" Or Sheets(i).Name = "PS1" Or Sheets(i).Name = "HB1" Or Sheets(i).Name = "HB2" Or Sheets(i).Name = "Pack'R" Then
    Sheets(i).Cells(lig, col) = mavar
    End If
  Next
  ctrl = False
End Sub

J'ai l'impression que c'est cette subtilité qui a résolu le bug

  Else
  Exit SuB