Emetre un son si cellule E3 ou E8 occupée

Re bonjour le forum

J'ai la macro ci-dessous je voudrais si c'est possible faire émettre un son si cellule E3 est occupée et inversement cellule E8

Merci pour vos éventuels retours

Private Sub Worksheet_Change(ByVal Target As Range)     'Macro pour interdire écriture cellule E3 ou E8 avec message

Application.EnableEvents = False
    If Not Intersect(Target, Union(Range("E3"), Range("E8"))) Is Nothing Then
        x = Range("E3").Value
        y = Range("E8").Value
        If (x <> "") And (y <> "") Then
            Target.ClearContents
            MsgBox "Impossible de saisir une valeur dans cellule " & Target.Address(rowabsolute:=False, columnabsolute:=False) & " car cellule " & IIf(Target.Address = "$E$8", "E3", "E8") & " renseigné"
    End If
    End If
Application.EnableEvents = True

End Sub

Bonjour toutes et tous

@Al87

en essayant de mettre un bip (Beep)

Private Sub Worksheet_Change(ByVal Target As Range)     'Macro pour interdire écriture cellule E3 ou E8 avec message

Application.EnableEvents = False
    If Not Intersect(Target, Union(Range("E3"), Range("E8"))) Is Nothing Then
        x = Range("E3").Value
        y = Range("E8").Value
        If (x <> "") And (y <> "") Then

    Target.ClearContents
            Beep  ' remodif coucou M12 et merci
MsgBox "Impossible de saisir une valeur dans cellule " & Target.Address(rowabsolute:=False, columnabsolute:=False) & " car cellule " & IIf(Target.Address = "$E$8", "E3", "E8") & " renseigné"
    End If
    End If
Application.EnableEvents = True

End Sub

crdlt,

André

Bonjour,

rajoute simplement à l'emplacement souhaité

Beep

re le forum

Pour l'instant ça ne fonctionne pas mais peut-être que je le met pas au bon endroit le Beep

Merci

Re,

Avant le msgbox qui t'affiche la non possibilité et avec le son en fonction

Re,

coucou M12

j'ai remodifié merci M12

Re,

Exemple

11al87.xlsm (14.01 Ko)

Re à tous,

Je ne sais pas si on s'est bien compris ou moi qui comprend pas

Lorsque je tape un nombre quelconque cellule E3 je ne peut pas en taper un cellule E8 i'ai le message mais pas le son

Je ne sais pas si c'est possible.

Merci à vous

Re le forum

J'ai trouvé ça que j'ai mis dans un module

Option Explicit

Private Declare Function PlaySound& Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName$, _
        ByVal hModule&, ByVal dwFlags&)

Const SND_SYNC = &H0
Const SND_ASYNC = &H1
Const SND_FILENAME = &H20000

Sub JouerSon()
Dim MonWav As String
    MonWav = "C:\Users\Toto\Desktop\Logoff.wav"     '... chemin et nom à adapter
    Call PlaySound(MonWav, 0&, SND_ASYNC Or SND_FILENAME)
End Sub

Ajout

JouerSon
Private Sub Worksheet_Change(ByVal Target As Range)     'Macro pour interdire écriture cellule E3 ou E8 avec message

Application.EnableEvents = False
    If Not Intersect(Target, Union(Range("E3"), Range("E8"))) Is Nothing Then
        x = Range("E3").Value
        y = Range("E8").Value
        If (x <> "") And (y <> "") Then
         JouerSon    ' le 14/02/2021
            Target.ClearContents
            MsgBox "Impossible de saisir une valeur dans cellule " & Target.Address(rowabsolute:=False, columnabsolute:=False) & " car cellule " & IIf(Target.Address = "$E$8", "E3", "E8") & " renseigné"
    End If
    End If
Application.EnableEvents = True

End Sub

Mais je n'arrive pas à trouver un son .Wav qui va bien avec (son bref)

Merci andre13

Je voudrais un son comme erreur de programme

Windows - Exclamation.Wav

Re

ici en milieu de page à gauche choisir sur la liste déroulante deux choix .mp3 ou .wav

http://www.universal-soundbank.com/windows.htm

re

bonsoir

tu peux aussi jouer ton beep perso (voir faire ta propre mélodie)

Declare Function ApiBeep Lib "kernel32" Alias "Beep" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long

Sub jouerbeepperso()
ApiBeep 400, 300
ApiBeep 300, 500
ApiBeep 200, 600
End Sub

Bonjour à tous

Toutes mes excuses à patricktoulon je n'ai pas vu ton message.

Ça fait bien le bip que je veux mais il faut le mettre où STP?

j'ai fait des modifs les voici ci-dessous dans ThisWorkbook (modifs du 14/02/2021) et ajouté dans un module

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim NombreJour As Integer
Dim Ladate As Date

  Application.ScreenUpdating = False
  If Target.Count > 1 Then Exit Sub
  Application.EnableEvents = False
  ' On recherche si la page est surveillée
  If Left(Sh.Name, 7) = "Charges" Then  'Le chiffre 7 = Nombre de lettres du mot "Charges".On peut mettre 8 avec un espace après "Charges " pour une sécurité.
    If Not Intersect(Range("B12:B112,E12:E112"), Target) Is Nothing Then

      If Target.Interior.ColorIndex = 2 Then
        ' Si la colonne B et la colonne E est vide on efface la date
        Range("A" & Target.Row) = IIf(Range("B" & Target.Row) & Range("E" & Target.Row) = "", "", Application.Proper(Format(Date, "dddd dd mmmm yyyy")))

        ' ********* Début Modifs. Tapez le Montant (colonnes E ou B) et éventuellement Modifier les Dates (Colonne A) sous le format suivant => 07/02/20 (Exemple)
      End If
      '
      ' Début modification du 05/08/2020 : Inscription automatique date en cellule A17
    ElseIf Not Intersect(Range("E7,J2"), Target) Is Nothing Then
      If Target = "" Then
        Range("A18").ClearContents           ' Suppression date si SUPPR cellule E6
      Else
        If Range("E18") = Range("E7") Then
          Range("A18") = Application.Proper(Format(Date, "dddd dd mmmm yyyy"))        ' Sinon on inscrit la date
        End If
      End If
      ' Fin modification du 05/08/2020 : Inscription automatique date en cellule A17
      '
    ElseIf Target.Column = 1 And Target.Row > 12 And Target.Interior.ColorIndex = 2 Then   'Ajout de And Target.Interior.ColorIndex = 2 pour pouvoir recopier texte ligne
      If IsDate(Target) Then
        Target = Application.Proper(Format(Target, "dddd dd mmmm yyyy"))        ' Sinon on inscrit la date
      Else
        Target = ""
        ' ***************** Fin modifs

      End If

    'Début modifs le 14/02/2021
    ElseIf Not Intersect(Target, Union(Range("E3"), Range("E8"))) Is Nothing Then
      x = Range("E3").Value
      y = Range("E8").Value
      If (x <> "") And (y <> "") Then
        JouerSon
        Target.ClearContents
        MsgBox "Impossible de saisir une valeur dans cellule " & Target.Address(rowabsolute:=False, columnabsolute:=False) & " car cellule " & IIf(Target.Address = "$E$8", "E3", "E8") & " renseigné"
      End If
    'Fin modifs le 14/02/2021

    End If
  End If
  Application.EnableEvents = True
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim NombreJour As Integer
Dim Ladate As Date

  Application.ScreenUpdating = False
  If Target.Count > 1 Then Exit Sub
  Application.EnableEvents = False
  ' On recherche si la page est surveillée
  If Left(Sh.Name, 7) = "Charges" Then  'Le chiffre 7 = Nombre de lettres du mot "Charges".On peut mettre 8 avec un espace après "Charges " pour une sécurité.
    If Not Intersect(Range("B12:B112,E12:E112"), Target) Is Nothing Then

      If Target.Interior.ColorIndex = 2 Then
        ' Si la colonne B et la colonne E est vide on efface la date
        Range("A" & Target.Row) = IIf(Range("B" & Target.Row) & Range("E" & Target.Row) = "", "", Application.Proper(Format(Date, "dddd dd mmmm yyyy")))

        ' ********* Début Modifs. Tapez le Montant (colonnes E ou B) et éventuellement Modifier les Dates (Colonne A) sous le format suivant => 07/02/20 (Exemple)
      End If
      '
      ' Début modification du 05/08/2020 : Inscription automatique date en cellule A17
    ElseIf Not Intersect(Range("E7,J2"), Target) Is Nothing Then
      If Target = "" Then
        Range("A18").ClearContents           ' Suppression date si SUPPR cellule E6
      Else
        If Range("E18") = Range("E7") Then
          Range("A18") = Application.Proper(Format(Date, "dddd dd mmmm yyyy"))        ' Sinon on inscrit la date
        End If
      End If
      ' Fin modification du 05/08/2020 : Inscription automatique date en cellule A17
      '
    ElseIf Target.Column = 1 And Target.Row > 12 And Target.Interior.ColorIndex = 2 Then   'Ajout de And Target.Interior.ColorIndex = 2 pour pouvoir recopier texte ligne
      If IsDate(Target) Then
        Target = Application.Proper(Format(Target, "dddd dd mmmm yyyy"))        ' Sinon on inscrit la date
      Else
        Target = ""
        ' ***************** Fin modifs

      End If

    'Début modifs le 14/02/2021
    ElseIf Not Intersect(Target, Union(Range("E3"), Range("E8"))) Is Nothing Then
      x = Range("E3").Value
      y = Range("E8").Value
      If (x <> "") And (y <> "") Then
        JouerSon
        Target.ClearContents
        MsgBox "Impossible de saisir une valeur dans cellule " & Target.Address(rowabsolute:=False, columnabsolute:=False) & " car cellule " & IIf(Target.Address = "$E$8", "E3", "E8") & " renseigné"
      End If
    'Fin modifs le 14/02/2021

    End If
  End If
  Application.EnableEvents = True
End Sub

Dans un module j'ai ça

Option Explicit

Private Declare Function PlaySound& Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName$, _
        ByVal hModule&, ByVal dwFlags&)

Const SND_SYNC = &H0
Const SND_ASYNC = &H1
Const SND_FILENAME = &H20000

Sub JouerSon()
Dim MonWav As String
    MonWav = "C:\Users\Toto\Desktop\Logoff.wav"         '... chemin et nom à adapter
    Call PlaySound(MonWav, 0&, SND_ASYNC Or SND_FILENAME)
End Sub

On progresse (moi non!!!)

Merci à plus peut-être

Cordialement

re

ben si le beep vba te convient

tu remplace "jouerson" par "Beep" dans l'event change et tu jette la sub jouerson du module

si c'est le beep mélodie que tu préfère

tu remplace "jouerson" par "" dans l'event change et tu remplace tout le code dans le module par la mienne

c'est tout

Re patricktoulon

Si j'ai bien compris Jouerson par beep

    'Début modifs le 14/02/2021
    ElseIf Not Intersect(Target, Union(Range("E3"), Range("E8"))) Is Nothing Then
      x = Range("E3").Value
      y = Range("E8").Value
      If (x <> "") And (y <> "") Then
        Beep
        Target.ClearContents
        MsgBox "Impossible de saisir une valeur dans cellule " & Target.Address(rowabsolute:=False, columnabsolute:=False) & " car cellule " & IIf(Target.Address = "$E$8", "E3", "E8") & " renseigné"
      End If
    'Fin modifs le 14/02/2021

et dans module

Option Explicit
Declare Function ApiBeep Lib "kernel32" Alias "Beep" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long

Sub jouerbeepperso()
ApiBeep 400, 300
ApiBeep 300, 500
ApiBeep 200, 600
End Sub

Si c'est ça fonctionne pas.

Mais ça doit venir de moi certainement

A+ peut-être

re

non si tu utilise apibeep tu met jouerbeepperso à la place de beep dans le if

rassure moi tu est bien sur window pas Mac hein!!?

Re

    'Début modifs le 14/02/2021
    ElseIf Not Intersect(Target, Union(Range("E3"), Range("E8"))) Is Nothing Then
      x = Range("E3").Value
      y = Range("E8").Value
      If (x <> "") And (y <> "") Then
        jouerbeepperso
        Target.ClearContents
        MsgBox "Impossible de saisir une valeur dans cellule " & Target.Address(rowabsolute:=False, columnabsolute:=False) & " car cellule " & IIf(Target.Address = "$E$8", "E3", "E8") & " renseigné"
      End If
    'Fin modifs le 14/02/2021

    End If
  End If
  Application.EnableEvents = True
End Sub

Et dans module

Declare Function ApiBeep Lib "kernel32" Alias "Beep" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long

Sub jouerbeepperso()
ApiBeep 400, 300
ApiBeep 300, 500
ApiBeep 200, 600
End Sub

Ç'est ça?

Non pas sous Mac

bon j'ai testé ca fonctionne chez moi

si j'ai bien compris l'intention

si E3 change et que E8 est remplie on beep

et l'inverse pareil si E8 change et que E3 est rempli on beep

mais si une des deux change et que l'autre est vide on beep pas

c'est bien ça ?

juste entre parenthèses les commentaire au niveau des adress de cell ne correspondent pas

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim NombreJour&, Ladate As Date, x As Boolean
  Application.ScreenUpdating = False
  If Target.Count > 1 Then Exit Sub
  Application.EnableEvents = False
  ' On recherche si la page est surveillée
  If Left(Sh.Name, 7) = "Charges" Then  'Le chiffre 7 = Nombre de lettres du mot "Charges".On peut mettre 8 avec un espace après "Charges " pour une sécurité.

    If Not Intersect(Range("B12:B112,E12:E112"), Target) Is Nothing Then
      If Target.Interior.ColorIndex = 2 Then
        ' Si la colonne B et la colonne E est vide on efface la date
        Range("A" & Target.Row) = IIf(Range("B" & Target.Row) & Range("E" & Target.Row) = "", "", Application.Proper(Format(Date, "dddd dd mmmm yyyy")))
        ' ********* Début Modifs. Tapez le Montant (colonnes E ou B) et éventuellement Modifier les Dates (Colonne A) sous le format suivant => 07/02/20 (Exemple)
      End If
      '

      ' Début modification du 05/08/2020 : Inscription automatique date en cellule A17
    ElseIf Not Intersect(Range("E7,J2"), Target) Is Nothing Then
      If Target = "" Then
        Range("A18").ClearContents           ' Suppression date si SUPPR cellule E6
      Else
        If Range("E18") = Range("E7") Then
          Range("A18") = Application.Proper(Format(Date, "dddd dd mmmm yyyy"))        ' Sinon on inscrit la date
        End If
      End If

      ' Fin modification du 05/08/2020 : Inscription automatique date en cellule A17
      '
    ElseIf Target.Column = 1 And Target.Row > 12 And Target.Interior.ColorIndex = 2 Then   'Ajout de And Target.Interior.ColorIndex = 2 pour pouvoir recopier texte ligne
      If IsDate(Target) Then
        Target = Application.Proper(Format(Target, "dddd dd mmmm yyyy"))        ' Sinon on inscrit la date
      Else
        Target = ""
        ' ***************** Fin modifs
      End If

    'Début modifs le 14/02/2021
    ElseIf Not Intersect(Target, Union(Range("E3"), Range("E8"))) Is Nothing Then
           x = Range("E3").Value <> "" And Range("E8").Value <> ""
            If x Then
        jouerbeepperso
        Target.ClearContents
        MsgBox "Impossible de saisir une valeur dans cellule " & Target.Address(0, 0) & " car cellule " & IIf(Target.Address = "$E$8", "E3", "E8") & " renseigné"
      End If
    'Fin modifs le 14/02/2021

    End If
  End If
  Application.EnableEvents = True
End Sub

Re

Au départ les 2 cellules E3 et E8 sont vides. Si le bilan de mes charges de l'année 2020 sont négatives de 100€ par exemple je mets 100€ dans cellule E3

Donc je ne peux pas mettre 100 € dans cellule E8 sinon message et beep

Inversement si positives 100€ dans cellule E8 et je ne peux pas mettre 100 € dans cellule E3 sinon message et beep

D'avance merci

Rechercher des sujets similaires à "emetre occupee"