placer une interdiction

[goldkeefer]

Bonjour , à vous tous
je vous présente mes meilleurs vœux pour cette année qui démarre
Je sollicite votre aide pour un petit problème que je rencontre
Je voudrais pouvoir interdire que 2 personnes soient présentes,sur le même site
le même jour est ce possible ?
vous en remerciant d'avance
je vous joint ma pièce
Cordialement
Alain

 

[kjin]

Re : placer une interdiction

Bonjour,
Macro événementielle dans le module de la feuille

Private Sub Worksheet_Change(ByVal Target As Range)
Dim L%
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("B10:J40")) Is Nothing Then
    L = Target.Row
    Select Case Target
        Case "Lorry", "Bsm", "Vallières", "Patrotte"
            If Application.CountIf(Range("B" & L & ":J" & L), Target) > 1 Then
                Application.Undo
            End If
    End Select
End If
End Sub

A+
kjin

 

[jp14]

Re : placer une interdiction

Bonjour goldkeefe
Salut kjin

Une autre macro évènementielle qui modifie la liste de validation en fonction des sites déjà utilisées.

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim cellule As Range
Dim coll As New Collection
Dim i As Long
Dim data1 As Variant
' on remplit une collection
If Target.Count > 1 Then Exit Sub
' pour sortir si la cellule n'est pas dans la plage
If Intersect(Target, Range("B10:J40")) Is Nothing Then Exit Sub
For Each cellule In Worksheets("Infos").Range("l1:l20")
        If cellule <> "" Then coll.Add cellule, CStr(cellule)
Next cellule
' on supprime les sites présent dans la collection si les sites sont dans la ligne sélectionnée
With Worksheets(Target.Worksheet.Name)
    For Each cellule In .Range("b" & Target.Row & ":j" & Target.Row)
        Select Case cellule
            Case "Lorry", "Bsm", "Vallières", "Patrotte"

                On Error GoTo suite1
                coll.Add cellule, CStr(cellule)
        End Select
    Next cellule
        
    'Application.ScreenUpdating = True
        
    'End If
'flag = False
End With
For i = 1 To coll.Count
    If coll(i) <> "" Then
        If i = 1 Then
            data1 = coll(i)
        Else
            data1 = data1 & "," & coll(i)
        End If
    End If
Next i
valid Target, data1
Exit Sub
suite1:
coll.Remove cellule
Resume Next
End Sub


Sub valid(cellule As Range, data1 As Variant)

With cellule.Validation
    .Delete
    .Add xlValidateList, xlValidAlertStop, xlBetween, data1
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
End With
End Sub

A tester

JP

 

[goldkeefer]

Re : placer une interdiction

Merci, Messieurs de votre réponse ultra rapide
Mais dans la nullité je suis une sommité , je n'ai jamais fait de macro
malheureusement je ne sais pas ou placer vos codes
si vous avez la même en formules je suis preneur
merci de votre compréhension
cordialement
Alain

 

[phlaurent55]

Re : placer une interdiction

Bonjour à tous,

Merci, Messieurs de votre réponse ultra rapide
Mais dans la nullité je suis une sommité , je n'ai jamais fait de macro
malheureusement je ne sais pas ou placer vos codes
si vous avez la même en formules je suis preneur
merci de votre compréhension
cordialement
Alain

je doute fort qu'on puisse faire la même chose avec des formules

je te retourne le fichier avec le code de Kijn qui est absent en ce moment

à+
Philippe

 

[goldkeefer]

Re : placer une interdiction

Merci à toi
Ph Laurent
je vais regarder cela et vous tiens au courant demain
Bonne nuit
Cordialement
Alain

 

[goldkeefer]

Re : placer une interdiction

Bonjour , Philippe
Cela marche impeccablement
Désolé juste un petit Hic je viens d"apprendre par mon Directeur ,
que à partir d'aujourd'hui , nous allons tourner à 2 personnes par site (Sur Bsm Et Lorry)
donc cela ne nécessite plus cette alerte
encore désolé de t'avoir mis à contribution pour rien
mais je garde le fichier on ne sait jamais des fois qu' il change d'avis
Encore un grand merci à toi ainsi qu'à Kjin pour ce super coup de main
Amicalement
Alain