Macro sans bouton avec multiple action

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
C

cj welch

XLDnaute Occasionnel
bonsoir le forum,

je voudrais a partir d'une cellule B1, que lorsque je modifie la valeur de cette cellule les èvenement suivant se passe :

-Effacer la cellule B2, les colonnes (h9:h48),(I9:I48),(j9:j48),(k9;k49),(u9:u48), je voudrais un message avant me demandent de confirmer mon choix.

-Enregistrer le classeur sous un nom spécifique et a un endroi déterminé avec la valeur de la cellule B1(B1 est une date) (ex: véhicule octobre 2008)dans le dossier voiture). Là aussi je voudrais un message me demandant l'enregistrement de ce nouveau dossier

Je suis nul en vba et j'ai besoins de votre aide

merci d'avance
 
Dernière édition:
Trier par date Trier par votes
Re : Macro sans bouton avec multiple action

Bonsoir CJ Welch,

Un exemple de macro possible :

Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim r As Byte
Dim NomFichier$
If Target = Cells(1, 2) Then
r = MsgBox("Voulez vous lancer l'effacement ?", vbYesNo, "Effacement ?")
    If r = 6 Then
        Cells(2, 2).ClearContents
        Range(Cells(9, 8), Cells(48, 11)).ClearContents
        Range(Cells(9, 21), Cells(48, 21)).ClearContents
    End If

NomFichier = "Fichier" & Target.Value & ".xls"
r = MsgBox("Voulez vous enregister le classeur sous le nom :" & NomFichier, vbYesNo, "Effacement ?")
If r = 6 Then ActiveWorkbook.SaveAs (NomFichier)
End If
End Sub
Bonne soirée
Kotov
 
Vote positif 0 Vote négatif
Re : Macro sans bouton avec multiple action

Bonsoir à tous


Kotov: une petite question (pour ma gouverne)

Est-ce la même chose si on utilise cette syntaxe ?

Code: 
Union(Cells(2, 2), Range(Cells(9, 8), Cells(48, 11)), _
Range(Cells(9, 21), Cells(48, 21))).ClearContents
 
Vote positif 0 Vote négatif
Re : Macro sans bouton avec multiple action

salut kotov, staple, bigfish,

je viens d'essayé le code, il plante au niveau des effacements
Range(Cells(9, 8), Cells(48, 11)).ClearContents

de plus, je me suis peut etre mal exprimé, mais je parle de colonne H9 a H48,I9 à I48, etc

Enfin, serait il possible que si on répond non la la procèdure d'effacement, la procèdure d'enregistrement se ne lance pas.

Encore merci pour votre aide
 
Vote positif 0 Vote négatif
Re : Macro sans bouton avec multiple action

Bonjoue


Essaie ces deux macros sur un classeur vierge

Tu verras que cela fonctionne

Code: 
Sub Essaie_I()
Range("A1:F20").Formula = "=ROW()*COLUMN()"
m = MsgBox("Effacement Méthode I, Cliquez sur OK")
If m = 1 Then
Range("A1:B3,C6:D8,E10:F12").ClearContents
End If
End Sub
Sub Essaie_II()
Range("A1:F20").Formula = "=ROW()*COLUMN()"
m = MsgBox("Effacement Méthode II, Cliquez sur OK")
If m = 1 Then
Union(Range(Cells(1, 1), Cells(3, 2)), _
Range(Cells(6, 3), Cells(8, 4)), _
Range(Cells(10, 5), Cells(12, 6))).ClearContents
End If
End Sub
 
Vote positif 0 Vote négatif
Re : Macro sans bouton avec multiple action

Salut jm,

la macro marche en effet, mais elle ne correspond pas a mes souhaits.
En effet, il y effacement puis si effacement, enregistrement du classeur.

Sous entend tu qu'il faut que je façe un mixage des 2 codes ?

Cordialement

A+

A+
 
Dernière édition:
Vote positif 0 Vote négatif
Re : Macro sans bouton avec multiple action

Bonsoir à tous,

@ cj welch :
J'ai le sentiment que le code proposé hier ne plante pas sur les colonnes.
Range(Cells(9, 8), Cells(48, 11)).ClearContents se traduit par :
Efface les données de la plage de cellules de H9 à I48 ce qui revient bien à
effacer les plages (H9:H48; I9:48; J9:J48; K9:K48).
(Je n'avais pas remarqué que tu souhaitais également effacer K49).

Pour info, quand tu parles de colonnes, cela correspond à la colonne dans son intégralité (Column). Là, tu veux effacer des plages de cellules, certaines isolées, d'autres adjacentes.


En revanche, hier soir avant de me coucher, je me suis repassé de mémoire cette macro faite rapidement d'un premier jet, et j'ai réalisé trop tard (micro éteint) que tu risquais le bug si tu sélectionnes à la souris une plage de cellules plutôt qu'une seule cellule.
Je propose donc l'amélioration suivante :
Code: 
If Not Intersect(Target, Cells(1, 2)) Is Nothing Then 
à la place de
If Target = Cells(1, 2) Then

Voici un code qui fonctionne, preuve à l'appui du fichier joint (les cellules à effacer sont en jaune). Pour lancer la macro, sélectionne la cellule B1 :

Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim r As Byte
Dim NomFichier$
If Not Intersect(Target, Cells(1, 2)) Is Nothing Then
    r = MsgBox("Voulez vous lancer l'effacement ?", vbYesNo, "Effacement ?")
    If r = 6 Then Union(Cells(2, 2), Range(Cells(9, 8), Cells(48, 11)), Range(Cells(9, 21), Cells(48, 21)), Cells(49, 11)).ClearContents
    NomFichier = "Fichier" & Target.Value & ".xls"
    r = MsgBox("Voulez vous enregister le classeur sous le nom :" & NomFichier, vbYesNo, "Effacement ?")
    If r = 6 Then ActiveWorkbook.SaveAs (NomFichier)
End If
End Sub

@Staple1600 et Bigfish :

Staple, désolé d'avoir tardé à te répondre, j'ai peu de temps dispo en ce moment.
Cela dit, ta proposition avec Union est juste.
Le résultat est identique à
Cells(2, 2).ClearContents
Range(Cells(9, 8), Cells(48, 11)).ClearContents
Range(Cells(9, 21), Cells(48, 21)).ClearContents
mais en plusss beau ! S'il m'arrive de l'utiliser, j'avoue que je suis allé à l'essentiel avec un copier-coller. Mais je préfère ta solution.
Dans le même esprit, la proposition de Bigfish est plus simple ... mais efface les cellules et pas les plages de cellules (caractérisées par Range) :
Union(Cells(2, 2), Cells(9, 8), Cells(48, 11), Cells(9, 21), Cells(48, 21)).ClearContents
Efface B2, H9, K48, U9, U48.
Ce n'était pas, je crois, la demande de cjwelch.

Bonne soirée à tous
Kotov
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
Re : Macro sans bouton avec multiple action

Ok,

Juste un End If à rajouter après avoir décalé 3 lignes après le premier If r= 6 :
Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim r As Byte
Dim NomFichier$
If Not Intersect(Target, Cells(1, 2)) Is Nothing Then
    r = MsgBox("Voulez vous lancer l'effacement ?", vbYesNo, "Effacement ?")
    If r = 6 Then
        Union(Cells(2, 2), Range(Cells(9, 8), Cells(48, 11)), Range(Cells(9, 21), Cells(48, 21)), Cells(49, 11)).ClearContents
        NomFichier = "Fichier" & Target.Value & ".xls"
        r = MsgBox("Voulez vous enregister le classeur sous le nom :" & NomFichier, vbYesNo, "Effacement ?")
        If r = 6 Then ActiveWorkbook.SaveAs (NomFichier)
    [Color=blue]End If[/color]
End If
End Sub

Bonne soirée
Kotov
 
Vote positif 0 Vote négatif
Re : Macro sans bouton avec multiple action

re

ça fonctionne super

Juste une petite chose le format de la cellule B1 est en format date (mmmm aaaa), je voudrais à l'enregistrement du fichier que le nom soit :fichier mars 2008 par exemple.

De plus, je voudrais que la macro se lance quand on modifie la cellule, je connais le code, il suffit d'enlever a la première ligne le mot "selection". Seulement dans le classeur ou va etre integré cette macro, j'ai déja une commande "Private Sub Worksheet_Change(ByVal Target As Range)", y at'il une autre possibilité ?


merci encore
 
Dernière édition:
Vote positif 0 Vote négatif
Re : Macro sans bouton avec multiple action

Re,

1.Enregistrement avec la date :
Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim r As Byte
Dim NomFichier$
If Not Intersect(Target, Cells(1, 2)) Is Nothing Then
    r = MsgBox("Voulez vous lancer l'effacement ?", vbYesNo, "Effacement ?")
    If r = 6 Then
        Union(Cells(2, 2), Range(Cells(9, 8), Cells(48, 11)), Range(Cells(9, 21), Cells(48, 21)), Cells(49, 11)).ClearContents
        
        If IsDate(Cells(1, 2)) Then
            [color=red]NomFichier = Format(CDate(Cells(1, 2)), "mmmm") & " - " & CStr(Year(Cells(1, 2))) & ".xls"[/color]
        Else: Exit Sub
        End If
        r = MsgBox("Voulez vous enregister le classeur sous le nom : " & NomFichier, vbYesNo, "Effacement ?")
        If r = 6 Then ActiveWorkbook.SaveAs (NomFichier)
    End If
End If
End Sub


2. Intégration de cette macro dans la procédure évènementielle Worksheet_Change
Plusieurs options :
a) tu copies ce code dans la macro existante juste avant le End Sub (attention toutefois à ce que tes 2 macros associées ne comportent pas des incompatibilités ex : variables déclarées avec des types incompatibles)

exemple :
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
'------- Macro 1 :
Msgbox "Je suis la macro n°1"

'--------macro 2 :
Dim r As Byte
Dim NomFichier$
If Not Intersect(Target, Cells(1, 2)) Is Nothing Then
    r = MsgBox("Voulez vous lancer l'effacement ?", vbYesNo, "Effacement ?")
    If r = 6 Then
        Union(Cells(2, 2), Range(Cells(9, 8), Cells(48, 11)), Range(Cells(9, 21), Cells(48, 21)), Cells(49, 11)).ClearContents
        
        If IsDate(Cells(1, 2)) Then
            NomFichier = Format(CDate(Cells(1, 2)), "mmmm") & " - " & CStr(Year(Cells(1, 2))) & ".xls"
        Else: Exit Sub
        End If
        r = MsgBox("Voulez vous enregister le classeur sous le nom : " & NomFichier, vbYesNo, "Effacement ?")
        If r = 6 Then ActiveWorkbook.SaveAs (NomFichier)
    End If
End If
End Sub

b) Autre option : copier les 2 macros dans un module en leur donnant un nom particulier (Macro1 et Macro2). Puis dans insérer ces 2 noms dans ta macro Worksheet_Change :
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Macro1
Macro2
End Sub
Personnellement, je préfère cette 2ème option, beaucoup plus limpide.

A toi de choisir
A+
Kotov
 
Vote positif 0 Vote négatif
Re : Macro sans bouton avec multiple action

re

le code fonctionne a merveille. j'ai 2 petite demande :

si je veux que le fichier a creer suive un chemin particulier qu'elle ligne faut 'il rajouter ?

Autre option : copier les 2 macros dans un module en leur donnant un nom particulier (Macro1 et Macro2). Puis dans insérer ces 2 noms dans ta macro Worksheet_Change :
Cliquez pour agrandir...

cette solution me semble très intéressante,seulement l'essai que j'ai fait ma affiché des messages d'erreur que je n'ai pas réussi a solutionner. Si maintenant,je voulais faire fonctionner le code que tu as élaboré avec un bouton, Quelle modif faut il apporter au code ?

Merci
 
Vote positif 0 Vote négatif
Re : Macro sans bouton avec multiple action

Re,

a) pour le chemin prédéfini (imaginons sur le disque C, dans le dossier "MesDocuments" et dans le sous dossier "FichierAuto") :
Code: 
NomFichier = [color=red]"C:\MesDocuments\FichierAuto\" & [/color] Format(CDate(Cells(1, 2)), "mmmm") & " - " & CStr(Year(Cells(1, 2))) & ".xls"

B) pour lancer la macro à partir d'un bouton (que tu dois bien évidemment créer) :
Code: 
Private Sub CommandButton1_Click()
Macro1
End Sub
ou
Code: 
Private Sub CommandButton1_Click()
Dim r As Byte
Dim NomFichier$
If Not Intersect(Target, Cells(1, 2)) Is Nothing Then
    r = MsgBox("Voulez vous lancer l'effacement ?", vbYesNo, "Effacement ?")
    If r = 6 Then
        Union(Cells(2, 2), Range(Cells(9, 8), Cells(48, 11)), Range(Cells(9, 21), Cells(48, 21)), Cells(49, 11)).ClearContents
        
        If IsDate(Cells(1, 2)) Then
           NomFichier = [color=red]"C:\MesDocuments\FichierAuto\" & [/color] Format(CDate(Cells(1, 2)), "mmmm") & " - " & CStr(Year(Cells(1, 2))) & ".xls"
        Else: Exit Sub
        End If
        r = MsgBox("Voulez vous enregister le classeur sous le nom : " & NomFichier, vbYesNo, "Effacement ?")
        If r = 6 Then ActiveWorkbook.SaveAs (NomFichier)
    End If
End If

End Sub

A+
Kotov
 
Vote positif 0 Vote négatif
Re : Macro sans bouton avec multiple action

re,

j'ai testé le dernier code et j'ai un message d'erreur qui me dit 'erreur d'exécution 424 :
objet requis et il me renvoi a la ligne
If Not Intersect(Target, Cells(1, 2)) Is Nothing Then

De plus, pourrait tu modifier le code, si c'est possible, il serais bien que le bouton
Lorsqu'on appuis, permette la saisie en B1
Quand on rappuis, bloc la saisie en b1 et lance la macro que tu as brillamant élaboré
Pourrait tu aussi donnée 2 noms au bouton quand écriture autorisé un "A", quand interdite un "I"

Merci encore
 
Dernière édition:
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

tactic6
  • Question Question
XL 2016 Aide pour userform (sujet clos)
Réponses
8
Affichages
736
tactic6
tactic6
D
  • Question Question
Procédure trop grande
2 3 4
Réponses
46
Affichages
10 K
domeli
D
Retour