Lancer une macro automatique sous conditions

Le 19/01/2013 à 21:19

Bonjour,

Depuis plusieurs jours et plusieurs testes je cale grave sur une formule a savoir :

Si A4 = AW25, alors macro, sinon rien

Jai ce code mais il ne fonctionne pas

Private Sub Worksheet_Change(ByVal Target As Range)
If Range("$A$4").Value = Range("$AW$25").Value Then
Call Son4
If Range("$A$4").Value <> Range("$AW$25").Value Then
Exit Sub
End If
End If
End Sub

Si vous pouvez me corriger ou m'aider

Merci

Le 19/01/2013 à 21:54

Bonsoir

Ton code fonctionne mais pas bien structuré

Essayes

Private Sub Worksheet_Change(ByVal Target As Range)
  If Range("$A$4").Value = Range("$AW$25").Value Then
    Call Son4
  End If
End Sub

Indentes ton code

Ton code indenté

Private Sub Worksheet_Change(ByVal Target As Range)
  If Range("$A$4").Value = Range("$AW$25").Value Then
    Call Son4
    If Range("$A$4").Value <> Range("$AW$25").Value Then
      Exit Sub
    End If
  End If
End Sub
Le 19/01/2013 à 22:09

Merci pour ta réponse

J explique mon cas ( j'aurais du commencer par là )

Jai un combobox avec liste déroulante ou je choisi le nom d'un cavalier " dossier concours hippique"

dans un userform1

A la fin de l'epreuve je fait par un bouton sur mon userform "copier le résultat" cela alimente la cellule A4

le cavalier est donc premier "en A4"

pour le cavalier suivant si ses résultats sont inférieurs au premier alors cellule A5

Pour le 3ème cavalier si ses résultats sont meilleurs que le premier alors en A4 et appel de la macro

etc........

Jai créer une cellule perdue dans la meme feuille AW25 = à nom du cavalier de ma liste déroulante que je compare à A4 donc

SI A4= AW25 alors macro

Si A4 <> de AW25 alors rien

Voila

j'espère m'etre bien expliquer

et merci encore

Le 19/01/2013 à 22:21

Bonsoir

Oui et .....

La macro ne sera exécutée que dans le cas ou A4 = AW25

C'est bien ce que tu voulais

A la modification de AW25 la macro "Worksheet_Change" est appelée, effectuera le test et si égalité appellera ta macro

Ne connaissant pas ton programme, je te conseille quand même de cibler la zone de surveillance de la macro "Worksheet_Change" style

If Not Intersect(Range("AW25"),Target) Is Nothing Then
Le 19/01/2013 à 22:31

Merci encore

j'ai fait les testes avec tes infos

ca marche PRESQUE

a savoir que la macro se déclenche pour le premier cavalier mais ensuite non

il faudrai qu'elle se déclenche a chaque fois qu'il y a un nouveau premier placé en A4

Merci

Voici le code de ma feuille :

Private Sub BTN_Efface_Click()

'=== Efface les resultat de la feuille

'
    Range("A4:Y80,AA4:AB80").Select ' efface les données mais pas le Total point en Z
    Range("A4").Activate
    Selection.ClearContents

End Sub
Sub CommandButton3_click()
Call imprimer
End Sub
Private Sub CommandButton1_Click()

  Range("AD3:AG80").Select
    Range("AD3").Activate
    Selection.ClearContents

End Sub

Private Sub classement_Click()
Dim L As Integer
L = Range("A65536").End(xlUp).Row
Range("A4:AB" & L).Select
 If Range("A4").Value = "" Then
 MsgBox ("Pas de Participants")
 Else
    Selection.Sort Key1:=Range("Z4"), Order1:=xlAscending, Key2:=Range("AB4") _
        , Order2:=xlAscending ', key3:=Range("F2"), order3:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
        :=xlSortNormal
 End If
End Sub
Private Sub Lance_appli_click()
UserForm1.Show vbModeless
End Sub

Private Sub CommandButton2_Click()

    Range("AI1:AP82").Select
    Range("AI1").Activate

End Sub

Private Sub CommandButton4_Click()

    Range("AD1:AH80").Select
    Range("AD1").Activate

End Sub

Sub CommandButton5_Click()
Call imprimer
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
  If Range("$A$4").Value = Range("$AW$25").Value Then
  If Not Intersect(Range("AW25"), Target) Is Nothing Then
    Call Son4
  End If
   End If
End Sub
Le 19/01/2013 à 22:35

Bonsoir

Ton macro Worksheet_Change(ByVal Target As Range) elle est placée où ?

Il faut qu'elle soit dans le module de la feuille

Comme tu avais parle de Userform, j'ai un doute

Ton fichier serait souhaitable

en plus ta macro devrait plutôt ressembler à ceci

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Range("AW25"), Target) Is Nothing Then
     If Range("$A$4").Value = Range("$AW$25").Value Then
      Call Son4
    End If
  End If
End Sub

Edit désolé je n'avais pas vu que tu vais marqué que c'était le code de ta feuille

Le 20/01/2013 à 19:11

Désolé pour ce changement de fil

je n'ai pas encore tous les automatisme du forum

Voici mes codes mis sur ma feuille :

Private Sub BTN_Efface_Click()

'=== Efface les resultat de la feuille

'
    Range("A4:Y80,AA4:AB80").Select ' efface les données mais pas le Total point en Z
    Range("A4").Activate
    Selection.ClearContents

End Sub
Sub CommandButton3_click()
Call imprimer
End Sub
Private Sub CommandButton1_Click()

  Range("AD3:AG80").Select
    Range("AD3").Activate
    Selection.ClearContents

End Sub

Private Sub classement_Click()
Dim L As Integer
L = Range("A65536").End(xlUp).Row
Range("A4:AB" & L).Select
 If Range("A4").Value = "" Then
 MsgBox ("Pas de Participants")
 Else
    Selection.Sort Key1:=Range("Z4"), Order1:=xlAscending, Key2:=Range("AB4") _
        , Order2:=xlAscending ', key3:=Range("F2"), order3:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
        :=xlSortNormal
 End If
End Sub
Private Sub Lance_appli_click()
UserForm1.Show vbModeless
End Sub

Private Sub CommandButton2_Click()

    Range("AI1:AP82").Select
    Range("AI1").Activate

End Sub

Private Sub CommandButton4_Click()

    Range("AD1:AH80").Select
    Range("AD1").Activate

End Sub

Sub CommandButton5_Click()
Call imprimer
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Range("AW25"), Target) Is Nothing Then
     If Range("$A$4").Value = Range("$AW$25").Value Then

      Call Son4

    End If
  End If
End Sub

Avec cela mon probleme est que ma macro se déclenche uniquement au premier test et ne se renouvelle pas lors

du nouveaux changement dans la cellule A4

Merci encore pour votre aide

Le 20/01/2013 à 21:24

Bonsoir

je croyais que la cellule perdue était AW25

Changes ta macro

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Range("A4"), Target) Is Nothing Then
     If Range("$A$4").Value = Range("$AW$25").Value Then

      Call Son4

    End If
  End If
End Sub

Ton fichier serait à mon avis indispensable

BIGBEN31 a écrit :

A la fin de l'epreuve je fait par un bouton sur mon userform "copier le résultat" cela alimente la cellule A4

Donc à tous les coups tu modifies A4

Je ne sais pas si dans macro "Son4" tu modifies de nouveau A4 (pour faire un classement par exemple)

Si tel est le cas il faudra penser à empêcher la macro "Worksheet_Change" sauf si à ce moment AW25 est changé

C'est compliqué , mais juste avec le code difficile de voir tous les enchainements

Le 20/01/2013 à 22:00

Merci d'avoir répondu

excuse c'est bien AW25 la cellule perdue

et c'est également pour un classement conditionnel qui renvoi en A4 le nom du cavalier premier de ce classement

et qui doit effectivement lancer ma macro pour chaque fois qu'un nouveaux cavalier en fonction de ses résultats passe premier donc en A4

De quel fichier as tu besoin

Userform

macro

?

USF :

Private fin_chrono As Long
Public EpreuveAdresse As String
Public EpreuveNom As Variant

Private Sub BTN_Annule_Click()
Unload Me
End Sub

Private Sub BTN_Copie_resultat_Click()

Dim Ligne As Long
Dim Point As Integer
Dim L As Integer

Point_obstacle = 0
Point_Refus = 0

Ligne = [B65536].End(xlUp).Row + 1
Range("AB" & Ligne) = Chrono.Caption      ' Chrono
Range("A" & Ligne) = Liste_cavalier            ' cavalier
Range("AW25") = Liste_cavalier
Range("B" & Ligne) = Cheval               ' Cheval
Range("C" & Ligne) = Ecurie               ' Ecurie

'=== Decompte des points=======

      '========== Points fautes obstacles
   If UserForm1.Obstacle_1 = True Then
    Range("D" & Ligne) = 4
        End If
   If UserForm1.Obstacle_2 = True Then
    Range("E" & Ligne) = 4
        End If
   If UserForm1.Obstacle_3 = True Then
    Range("F" & Ligne) = 4
         End If
   If UserForm1.Obstacle_4 = True Then
    Range("G" & Ligne) = 4
         End If
   If UserForm1.Obstacle_5 = True Then
    Range("H" & Ligne) = 4
         End If
    If UserForm1.Obstacle_6 = True Then
    Range("I" & Ligne) = 4
         End If
    If UserForm1.Obstacle_7 = True Then
    Range("J" & Ligne) = 4
        End If
    If UserForm1.Obstacle_8 = True Then
    Range("K" & Ligne) = 4
        End If
    If UserForm1.Obstacle_9 = True Then
    Range("L" & Ligne) = 4
        End If
    If UserForm1.Obstacle_10 = True Then
    Range("M" & Ligne) = 4
        End If
    If UserForm1.Obstacle_11 = True Then
    Range("N" & Ligne) = 4
        End If
    If UserForm1.Obstacle_12 = True Then
    Range("O" & Ligne) = 4
        End If

    '======== POINTS REFUS

     If UserForm1.refus_1 = True Then
     Range("P" & Ligne) = 4
        End If
     If UserForm1.refus_2 = True Then
     Range("Q" & Ligne) = 4
        End If
            '======= REFUS 3 100 point éliminé
            If UserForm1.refus_3 = True Then
            Range("R" & Ligne) = 100
            Range("AA" & Ligne) = "Eliminé(e)"
        End If

    '======== CHUTE Elimination
    If UserForm1.Chute_1 = True Then
    Range("S" & Ligne) = 100
    Range("AA" & Ligne) = "Eliminé(e)"
    End If
    '========== FAUTES Techniques
    If UserForm1.Faute_Tech_1 = True Then
    Range("T" & Ligne) = 4
        End If
   If UserForm1.Faute_Tech_2 = True Then
    Range("U" & Ligne) = 4
        End If
   If UserForm1.Faute_Tech_3 = True Then
    Range("V" & Ligne) = 4
         End If
   If UserForm1.Faute_Tech_4 = True Then
    Range("W" & Ligne) = 4
         End If
   If UserForm1.Faute_Tech_5 = True Then
    Range("X" & Ligne) = 4
         End If

        If UserForm1.Faute_Tech_Elimine = True Then
        Range("Y" & Ligne) = 100
        Range("AA" & Ligne) = "Eliminé(e)"
         End If

'======== TRIE en sortant============
'Dim L As Integer
L = Range("A65536").End(xlUp).Row
Range("A4:AB" & L).Select

 If Range("A4").Value = "" Then
 MsgBox ("Pas de Participants")
 Else
    Selection.Sort Key1:=Range("Z4"), Order1:=xlAscending, Key2:=Range("AB4"), Order2:=xlAscending

 End If

End Sub
Private Sub BTN_Depart_Click()
    CumulTimer = 0
    GoTimer = Timer
    'Précision de IntervalT à adapter selon possibilités d'affichage
    TimerOn IntervalT:=50                   'en millièmes de seconde

    BTN_Depart.Enabled = False
    BTN_Reprendre.Enabled = False
    BTN_Fin.Enabled = True
    BTN_Pause.Enabled = True
End Sub

Private Sub BTN_Pause_Click()
    TimerOff
    CumulTimer = CumulTimer + (Timer - GoTimer)

    BTN_Pause.Enabled = False
    BTN_Reprendre.Enabled = True
End Sub

Private Sub BTN_Reprendre_Click()
    GoTimer = Timer
    TimerOn IntervalT:=50                   'en millièmes de seconde

    BTN_Pause.Enabled = True
    BTN_Reprendre.Enabled = False
End Sub

Private Sub BTN_Fin_Click()
    TimerOff

    BTN_Depart.Enabled = True
    BTN_Pause.Enabled = False
    BTN_Reprendre.Enabled = False
    BTN_Fin.Enabled = False

    'MsgBox "Le chrono est de : " & Chrono.Caption & vbLf & vbLf & "Attention: cette valeur n'est pas numérique (= chaine de caractères) !"
End Sub

Private Sub CommandButton6_click()

End Sub

Private Sub Concurent_Click()

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    TimerOff
End Sub

'Private Sub BTN_Depart_Click() ' Depart du Chrono
'Dim DEPART As Double
'Dim Temps As Double
'BTN_Depart.Enabled = False

'fin_chrono = 0
'DEPART = [now()]
'Do While fin_chrono = 0
    'Temps = [now()] - DEPART
        'If CheckBox1 = False Then
        'Chrono.Caption = WorksheetFunction.Text(Temps, "hh:mm:ss.00")
        'Else
        'Chrono.Caption = WorksheetFunction.Text(Temps, "hh:mm:ss")
    'End If
'DoEvents
'Loop

'End Sub
'Private Sub BTN_Fin_Click() 'Arrete le Chrono
'FIN
'End Sub

'==== SI CHUTE Arrete le Chrono
Private Sub Chute_1_Click() 'Case chute clic arrete le chrono
FIN
End Sub
'==== SI FAUTE Elimine Arrete le Chrono
Private Sub Faute_Tech_Elimine_Click() 'Case Faute tech elimine clic arrete le chrono
FIN
End Sub
'==== SI 3 refus Arrete le Chrono
Private Sub refus_3_Click() 'Case Refu 3 clic arrete le chrono
FIN
End Sub

Function FIN()
TimerOff
    BTN_Depart.Enabled = True
    BTN_Pause.Enabled = False
    BTN_Reprendre.Enabled = False
    BTN_Fin.Enabled = False
End Function

Private Sub Liste_cavalier_Change()
Dim EpreuveColonneCheval As String
Dim EpreuveColonneClub As String
Dim EpreuveColonneNuméro As String
'Dim EpreuveNom As Variant

EpreuveNom = ActiveWorkbook.ActiveSheet.Name
EpreuveColonneCheval = EpreuveNom & "!AE" 'Affiche le nom du cheval
EpreuveColonneClub = EpreuveNom & "!AF"   'Affiche le non du club
EpreuveColonneNuméro = EpreuveNom & "!AG"   'Affiche le Numéro

If Liste_cavalier.ListIndex = -1 Then Exit Sub

Me.Cheval.Value = Range(EpreuveColonneCheval & Liste_cavalier.ListIndex + 2)
Me.Ecurie.Value = Range(EpreuveColonneClub & Liste_cavalier.ListIndex + 2)
Me.Numéro.Value = Range(EpreuveColonneNuméro & Liste_cavalier.ListIndex + 2)

End Sub

Private Sub userForm_Initialize()
Dim T_limite As Double
Dim T_depasse As Double
'Dim EpreuveAdresse As String
'Dim EpreuveNom As Variant

Me.Liste_cavalier.ColumnCount = 3 'affecte 3 colonnes à la liste
Me.Nom_Epeuve = ActiveWorkbook.ActiveSheet.Name 'Affiche le nom de l'epreuve dans le Formulaire

EpreuveNom = ActiveWorkbook.ActiveSheet.Name 'Range("A1").Value
EpreuveAdresse = EpreuveNom & "!AD2:AF9" 'position de la liste
'MsgBox (EpreuveAdresse)

'========= Alimentation de la liste

Me.Liste_cavalier.RowSource = EpreuveAdresse & Sheets(EpreuveNom).Cells(1, 1).End(xlDown).Row

Me.Liste_cavalier.ColumnWidths = "130;75;60" 'Dimention des colone dans la liste
Me.Liste_cavalier.ListIndex = 0              ' affiche les données de la ligne 1

T_depasse = Sheets("Paramétres").Range("B2").Value
Me.Temps_depasse.Caption = WorksheetFunction.Text(T_depasse, "mm:ss.00")

T_limite = Sheets("Paramétres").Range("C2").Value
Me.Temps_limite.Caption = WorksheetFunction.Text(T_limite, "mm:ss.00")

T_Départ = Sheets("Paramétres").Range("D2").Value
Me.Temps_avant_départ.Caption = WorksheetFunction.Text(T_Départ, "mm:ss.00")

With UserForm1
.startUpPosition = 3
.Left = Application.Width - Me.Width
End With

End Sub

Private Sub CommandButton10_Click()
Call Son3
End Sub

Private Sub CommandButton11_Click()
Call Son4
End Sub
Private Sub BTN_RAZ_Click()
    TimerOff
    Chrono.Caption = "00:00:00"
    Dim Ctrl As Control, TheNum As Byte
For Each Ctrl In Me.Controls
If TypeOf Ctrl Is MSForms.CheckBox Then
With Ctrl
.Value = False
End With
End If
Next Ctrl
End Sub

Ma macro :

Sub Son4()
'
' Son4 Macro
' Macro enregistrée le 18/12/2012 par BIGBEN
'

'
    ActiveSheet.Shapes("Object 36").Select
    Selection.Verb Verb:=xlPrimary
End Sub

Voila je reste a votre écoute et encore maerci de vous pencher sur mon cas

Ah j'ai oublié

Ma macro =

Inserer objet son wave

objet 36

fichier son .wav de mon ordi

merci

Le 20/01/2013 à 22:26

Bonsoir

Banzai64 a écrit :

Ton fichier serait à mon avis indispensable

Le fichier ce n'est pas ce que tu as transmis, c'est l'ensemble : Ton programme Excel,celui qui te sert dans ce cas

Supposition

Quand tu cliques sur ton bouton "BTN_Copie_resultat" tu copies le "Liste_cavalier" dans la colonne A 1ère ligne vide, ainsi que dans Aw25

Ensuite un peu de cuisine

Et tu tries ton tableau

Mon idée

A la fin du tri de ton tableau c'est de tester A4 et Aw25 et d'appeler la macro si égalite

  L = Range("A65536").End(xlUp).Row
  Range("A4:AB" & L).Select

  If Range("A4").Value = "" Then
    MsgBox ("Pas de Participants")
  Else
    Selection.Sort Key1:=Range("Z4"), Order1:=xlAscending, Key2:=Range("AB4"), Order2:=xlAscending
If Range("A4") = Range("AW25") Then
      Call Son4
    End If
  End If
End Sub

Ainsi tu peux effacer ta macro Worksheet_Change

Si ce n'est pas ça il faut ton fichier ainsi que le mode d'emploi pour arriver au bug/non fonctionnement souhaité

Le 20/01/2013 à 23:23

Ok je prend acte

je teste ( demain matin ) because je parts au boulot

et je vous tiens au courant avec si necessaire bien sur envoie de mon dossier complet

merci bonne nuit

a demain

Le 22/01/2013 à 08:49

Bonjour,

CA MARCHE

Merci beaucoup pour votre aide effectivement avec votre aide ma fonction marche a merveille

Toutefois je souhaite te transmettre mon fichier car j'ai besoin de résoudre une fonction assez complexe (enfin pour moi)

et j'ai a nouveaux besoin d'aide

Comment faire pour envoyer mon fichier

Forum ou Privé

Merci

Le 22/01/2013 à 10:32

Bonjour

Le mieux c'est le forum, car même si j'en suis incapable de résoudre ton souci, d'autres membres le pourront

Tu le débarrasse des données personnelles

Tu t'assures qu'ainsi modifié il est toujours fonctionnel

TU indiques ton problème et la manière d'y arriver

Et tu le postes ici

Le 22/01/2013 à 11:59

Merci pour ta réponse rapide

Toutefois j'ai été refrodit déja une fois en mettant un dossier sur un forum, il a été copié et revendu aprés quelques petites modifs

Mon but pour mon dossier n'est absolument pas de le vendre mais de l'utiliser pour mon propre club d'équitation

Alors je suis un peu hésitant et je me méfis

Dois je fermer le fil de ma premiere question

et en relancer un autre pour mon nouveaux probleme EN Y ALLANT PETIT A PETIT

Merci de ton conseil

Le 22/01/2013 à 13:07

Bonjour

Je ne sais pas quoi te dire de plus

Lorsque tu exposes ton souci, si une partie de ton fichier suffit à cerner le problème, pourquoi pas ne pas y aller "petit à petit"

Mais il n'y a que toi qui peux le savoir

Rechercher des sujets similaires à "lancer macro automatique conditions"