Empecher double saisie

gibtoul

XLDnaute Junior
Bonjour à Tous

j'ai récuperé le code suivant pour eviter d'avoir sur les colonnes AS et AT une double saisie sur les celllules d'une meme ligne.

Je souhaiterais appliquer cela à plusieurs autre colonne : C et F , X et Z. ...;

Après plusieurs tentatives sans succès je fais appel au forum pour m'aider !!

Merci

A bientot

Gibtoul







Code:
Private Sub Worksheet_Change(ByVal zz As Range)
If Intersect(zz, Range("AS80:AT633")) Is Nothing Then Exit Sub
y = zz.Row
If Application.CountA(Range("AS" & y & ":AT" & y)) > 1 Then
Application.EnableEvents = False
MsgBox "Attention double saisie !!": zz = ""
Application.EnableEvents = True
End If
End Sub
 

david84

XLDnaute Barbatruc
Re : Empecher double saisie

Bonjour,
tu peux définir une plage de cellules discontinues en utilisant application.Union :
Code:
Dim MaPlage as Range
Set MaPlage=Application.Union(Range("C80:C633"),Range("T80:T633"),Range("AS80:AT633"))
et utiliser ensuite la plage MaPlage dans la suite de ton code, par exemple
Code:
If Intersect(zz, MaPlage) Is Nothing Then Exit Sub
Suite du code à adapter.
Code non testé mais je t'expose l'idée.
A+
 

gibtoul

XLDnaute Junior
Re : Empecher double saisie

Bonjour David84

Je te remercie pour ta réponse.

J'ai modifié le code de la facon suivante mais sans succès (je suis pas vraiment un expert ...)

as tu la possibilité de m'aiguiller

merci pour ton aide

a+


Private Sub Worksheet_Change(ByVal zz As Range)
If Intersect(zz, MaPlage) Is Nothing Then Exit Sub
y = zz.Row
Dim MaPlage As Range
Set MaPlage = Application.Union(Range("C80:C633"), Range("T80:T633"), Range("AS80:AT633"))
Application.EnableEvents = False
MsgBox "Attention double saisie !!": zz = ""
Application.EnableEvents = True
End If
End Sub
 

Pierrot93

XLDnaute Barbatruc
Re : Empecher double saisie

Bonjour,

En l'absence de David:), que je salue au passage, initialise la variable avant d'effectuer le test :

Code:
Private Sub Worksheet_Change(ByVal zz As Range)
Dim MaPlage As Range
Set MaPlage = Application.Union(Range("C80:C633"), Range("T80:T633"), Range("AS80:AT633"))
If Intersect(zz, MaPlage) Is Nothing Then Exit Sub
bonne journée
@+
 

gibtoul

XLDnaute Junior
Re : Empecher double saisie

Bonjour Pierrot

Merci pour ta réponse.

J'ai joins le fichier test car je bute pour la résolution. ... et puis je suis pas très clair dans mes explications.

Mon besoin est de ne pas pouvoir saisir sur une même ligne dans les colonne C et T
et avoir la meme possibilité sur les colonne AS et AT

les deux plages étant independantes

Le fichier test2 comporte le code initiale fonctionnant pour les plages AS et AT

Merci pour votre aide

Gibtoul
 

Fichiers joints

Dernière édition:

gibtoul

XLDnaute Junior
Re : Empecher double saisie

Bonjour

Je reviens vers vous sur la possible résolution de mon petit probleme de double saisie


A bientot

Gibtoul
 

Dranreb

XLDnaute Barbatruc
Re : Empecher double saisie

Bonjour.
Ce que je ne comprends pas bien c'est pourquoi on n'empêche pas la saisie plutôt que de la sanctionner.
Donc en corrigeant la sélection d'une cellule au profit de celle qui est renseignée puisqu'il faudrait donc d'abord l'effacer ?
 

gibtoul

XLDnaute Junior
Re : Empecher double saisie

bonjour Dranreb,

Effectivement cela peux etre la solution puisque l'objectif est qu'au final qu'une seule cellule soit renseignée sur une meme ligne et par rapport à 2 colonnes. Ca marche bien avec la macro du fichier test mais je n'arrive pas à la modifié pour avoir la meme fonctionalité sur un autre groupe de 2 colonnes
 

Dranreb

XLDnaute Barbatruc
Re : Empecher double saisie

Je propose donc :
VB:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim I As Long, LAutre As Range
If Target.Count <> 1 Then Exit Sub
If Intersect(Me.[80:633], Target) Is Nothing Then Exit Sub
For I = 0 To 3
   If Not Intersect(Me.Columns(Array("C", "T", "AS", "AT")(I)), Target) Is Nothing Then
      Set LAutre = Intersect(Me.Columns(Array("T", "C", "AT", "AS")(I)), Target.EntireRow)
      If Not IsEmpty(LAutre.Value) Then
         Application.EnableEvents = False
         LAutre.Select
         Application.EnableEvents = True: End If
      Exit Sub: End If
   Next I
End Sub
 

gibtoul

XLDnaute Junior
Re : Empecher double saisie

Dranreb

Je te remercie pour ta réactivité et efficacité, cela correspond à mon besoins.

A bientot

Gibtoul
 

gibtoul

XLDnaute Junior
Re : Empecher double saisie

Bonjour

je reviens sur le code sur lequel ,si cela est possible , avoir une amelioration.

Pour ma saisie sur une ligne et me deplacer de cellule en cellule , j'utilise les fleches du pavé gauche ou droite
Mais lorsque une saisie est faite sur une celulle ou je restreins la saisie je suis bloqué dans mon defilement
Est -il possible, lors d'un deplacement avec les fleches et lors d'un bloquage, de passer à la cellule suivante

je joins le fichiers exemple ou par exemple je suis bloqué sur la ligne 5 entre les colonnes D te S

Merci pour votre aide

a+
gibtoul
 

Fichiers joints

Dranreb

XLDnaute Barbatruc
Re : Empecher double saisie

Bonjour.
Je ne vois pas trop comment faire.
À moins qu'il ne soit en fin de compte pas très utile d'être renvoyé sur la cellule qui doit être modifiée d'abord, et qu'on peut, à la place se contenter d'une impossibilité de sélectionner la cellule vide si l'autre est renseignée.
Dans ce cas c'est facile: protégez la feuille sans mot de passe mais après avoir déverrouillé toute ses cellules de sorte que ce soit à peu près sans effet. Dans une Worksheet_Change à peut près écrite comme la Worksheet_SelectionChange au lieu de
LAutre.Select mettez LAutre.Locked = Not IsEmpty(Target.Value)
 

gibtoul

XLDnaute Junior
Re : Empecher double saisie

Bonjour Dranbeb

J'ai modifié le code , protegé la feuille en deverouillant les cellules concernées mais la saisie est rendu possible

Je joins le fichier modifié

a+

gibtoul
 

Fichiers joints

Dranreb

XLDnaute Barbatruc
Re : Empecher double saisie

Bonjour
Vous avez laissé le code dans une Worksheet_SelectionChange au lieu de le mettre dans une Worksheet_Change.
C'est désormais lorsqu'une cellule change qu'il faut changer LAutre.Locked. Et en principe LAutre est vide alors, inutile de le tester.
Mais je vous accorde que ce n'est pas facile à mettre au point.
Déjà parce que la protection va empêcher de le faire. Alors il faut d'abord ôter la protection puis la remettre après. Ou alors la refaire à l'ouverture du classeur (Workbook_Open) mais avec le paramètre UserInterfaceOnly:=True

Et verrouillez déjà au départ celles dont l'autre est renseignée.

Essayez comme ça:
VB:
Private Sub Worksheet_Activate()
Me.Protect Scenarios:=False, UserInterfaceOnly:=True, _
   AllowFormattingCells:=True, AllowFormattingColumns:=True, AllowFormattingRows:=True, _
   AllowInsertingRows:=True, AllowInsertingHyperlinks:=True, AllowDeletingRows:=True, _
   AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True
Me.EnableSelection = xlUnlockedCel
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim I As Long, LAutre As Range
If Target.Count <> 1 Then Exit Sub
If Intersect(Me.[3:10], Target) Is Nothing Then Exit Sub
For I = 0 To 3
   If Not Intersect(Me.Columns(Array("C", "T", "V", "W")(I)), Target) Is Nothing Then
      Set LAutre = Intersect(Me.Columns(Array("T", "C", "W", "V")(I)), Target.EntireRow)
      LAutre.Locked = Not IsEmpty(Target.Value)
      Exit Sub: End If
   Next I
On pourrait même ajouter derrière la modification de LAutre.Locked :
VB:
LAutre.Interior.Color = IIf(LAutre.Locked, 0, &HFFFF&)
 
Dernière édition:

gibtoul

XLDnaute Junior
Re : Empecher double saisie

bonsoir dranreb,

j'ai essayé d'appliqué les modifications mais sans succès.
je refais un test demain matin

je te tiens au courant

merci encore

a bientôt

gibtoul
 

gibtoul

XLDnaute Junior
Re : Empecher double saisie

bonjour Dranreb

Je ne suis pas arrivé à faire fonctionner le code avec la derniere modification.

En modifiant le code initial cela ne serait -il pas plus facile ?

Merci pour votre aide

a+

gibtoul
 

gibtoul

XLDnaute Junior
Re : Empecher double saisie

bonjour Si...

Je te remercie pour l'aide apportée , cela fonctionne parfaitement
pour l'adapter à mon projet global et si je souhaite le modifié pour d'autre usage. J'ai identifié quelque points mais il m'en manque

Case : correspond au n° de colonne
Case 3: B = R(1, 18) : 18 = nombre de colonne entre Case 3 vers Case 20 (y compris 3 et20)
Case 20: B = R(1, -16) = "": o = IIf(C > R.Column, 0, 2) : -16 = = nombre de colonne entre Case 20 vers Case 3

Je ne vois pas comment faire pour parametrer :
le nombre de ligne : dans l'exemple entre les lignes 3 à 10
Si je veux aller jusqu'à la ligne 15 , je dois intervenir sur quel parametre

Si je veux rajouter la fonction sur la case 55 et 56 , j'ai rajouter ces lignes sans succès:

Case 55: B = R(1, 2) = "": o = IIf(C > R.Column, 0, 2)
Case 56: B = R(1, 0) = "": o = IIf(C > R.Column, 0, 2


A bientot

gibtoul
 

Si...

XLDnaute Barbatruc
Re : Empecher double saisie

salut

tout dépend de la plage d'action que j'ai nommée P :
dans If R.Count = 1 And Not Intersect(R, Range("P")) Is Nothing Then
la plage concernée P est définie dans Formules, Gestionnaire de noms
(sélection de chaque morceau en gardant la touche Ctrl appuyée)
pour les décalages
Select Case R.Column selon le numéro de la colonne sélectionnée ou active
3 pour C, 20 pour T, 45 pour As et 46 pour AT

cas C : la variable B est mise à vrai si la cellule décalée de 18 colonnes à droite est vide
C D E ... T
1 2 3 ... 18
cas T : la variable B est mise à vrai si la cellule décalée de 16 colonnes à gauche (-) est vide
C ... R S T
-16 … -1 0 1

o = IIf(C > R.Column, 0, 2) : le décalage o de 1 colonne vers la gauche (0) ou de 2 colonnes vers la droite (2) dépend de la position précédente du curseur
 

Dranreb

XLDnaute Barbatruc
Re : Empecher double saisie

Bonjour.
Je m'aperçois que la protection que j'avais mi dans la Worksheet_Activate ne marchait pas pour une raison que je ne comprends pas. En effet je ne spécifiais pas Contents, mais l'aide indiquait pourtant que True était assumé. Enfin j'ai utilisé l'enregistreur pour la refaire et étoffé un peu le code. Ça donne ça :
VB:
Option Explicit

Private Sub Worksheet_Activate()
Dim L As Long, I As Long
Me.Protect DrawingObjects:=False, Contents:=True, Scenarios:=False, UserInterfaceOnly:=True, _
   AllowFormattingCells:=True, AllowFormattingColumns:=True, AllowFormattingRows:=True, _
   AllowInsertingRows:=True, AllowInsertingHyperlinks:=True, AllowDeletingRows:=True, _
   AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True
Me.EnableSelection = xlUnlockedCells
For L = 3 To 10
   For I = 0 To 3
      Verrou Me.Cells(L, Array("C", "T", "V", "W")(I)), _
             Me.Cells(L, Array("T", "C", "W", "V")(I))
      Next I
   Next L
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim I As Long, LAutre As Range
If Target.Count <> 1 Then Exit Sub
If Intersect(Me.[3:10], Target) Is Nothing Then Exit Sub
For I = 0 To 3
   If Not Intersect(Me.Columns(Array("C", "T", "V", "W")(I)), Target) Is Nothing Then
      Set LAutre = Intersect(Me.Columns(Array("T", "C", "W", "V")(I)), Target.EntireRow)
      Verrou Target, LAutre: Verrou LAutre, Target
      Exit Sub: End If
   Next I
End Sub

Private Sub Verrou(ByVal Cellule As Range, ByVal LAutre As Range)
If IsEmpty(LAutre.Value) Then
   Cellule.Interior.Color = &H80FFFF
   Cellule.Locked = False
ElseIf IsEmpty(Cellule.Value) Then
   Cellule.Interior.Color = &HC0C0C0
   Cellule.Locked = True
Else
   Cellule.Interior.Color = &H4040FF
   Cellule.Locked = False
   End If
End Sub
 
Haut Bas