Vous utilisez un navigateur obsolète. Il se peut que ce site ou d'autres sites Web ne s'affichent pas correctement. Vous devez le mettre à jour ou utiliser un navigateur alternatif.
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
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
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
@ 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.
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
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é ?
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.
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 :
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 ?
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
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"
Ce site utilise des cookies pour personnaliser le contenu, adapter votre expérience et vous garder connecté si vous vous enregistrez.
En continuant à utiliser ce site, vous consentez à notre utilisation de cookies.
