Emetre un son si cellule E3 ou E8 occupée

Le 14/02/2021 à 13:43

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
Le 14/02/2021 à 13:49

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é

Le 14/02/2021 à 13:50

Bonjour,

rajoute simplement à l'emplacement souhaité

Beep
Le 14/02/2021 à 14:07

re le forum

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

Merci

Le 14/02/2021 à 14:12

Re,

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

Le 14/02/2021 à 14:14

Re,

coucou M12

j'ai remodifié merci M12

Le 14/02/2021 à 14:18

Re,

Exemple

20al87.xlsm (14.01 Ko)
Le 14/02/2021 à 14:25

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

Le 14/02/2021 à 19:14

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)

Le 14/02/2021 à 19:22

Re

https://lasonotheque.org/search?q=bip

Le 14/02/2021 à 19:43

Merci andre13

Je voudrais un son comme erreur de programme

Windows - Exclamation.Wav

Le 14/02/2021 à 20:23

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

Le 14/02/2021 à 20:53

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
Le 15/02/2021 à 06:56

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

Le 15/02/2021 à 07:29

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

Le 15/02/2021 à 07:48

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

Le 15/02/2021 à 07:53

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!!?

Le 15/02/2021 à 08:18

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

Le 15/02/2021 à 08:25

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
Le 15/02/2021 à 08:34

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"