Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

Macro Événementiel

D

duplaly

XLDnaute Occasionnel
Bonjour
voir mon code vba pour ajustement. Tout fonctionne, mais je ne suis pas certain de la macro événementiel que j'ai rajoutée à la fin du premier macro.
j'aimerais en fonction de la valeur d'une cellule (F4) sur la feuille active copier ligne entière sur la feuillle adresse.
Voir mon code actuel pour aide.
Merci

Private Sub ComboBox1_Change()
Dim Derlg As Long, DD As Long, DF As Long
Dim Sh As Worksheet

Worksheets("Empl").Unprotect Password:="moncef"
Worksheets("Master").Unprotect Password:="moncef"
Worksheets("Master").Visible = True
'On inhibe la mise à jour affichage écran
Application.ScreenUpdating = False
With Sheets("Empl")
'On supprime l'éventuel filtre automatique
.AutoFilterMode = False
'La dernière ligne remplie de la colonna A
Derlg = .Range("A" & .Rows.Count).End(xlUp).Row
'Si ComboBox1 non vide
If Me.ComboBox1.Value <> "" Then
'En DD (date début), On transforme le contenu de DTPicker1 en Long
DD = CLng(Me.DTPicker1.Value)
'En DF (date Fin), on transforme le contenu de DTPicker2 en Long
DF = CLng(Me.DTPicker2.Value)
If DF > DD Then
'On filtre la colonne A entre DD et DF
.Range("A7:J" & Derlg).AutoFilter field:=1, Criteria1:=">=" & DD, Criteria2:="<=" & DF, Operator:=xlAnd
'Et on filtre la colonne H sur le texte entrée dans ComboBox1
.Range("A7:H" & Derlg).AutoFilter field:=8, Criteria1:=Me.ComboBox1.Text
'Si le résultat du filtre comporte plus d'une ligne (y compris la ligne 7, celle des titres)
If .Range("A7:A" & Derlg).SpecialCells(xlCellTypeVisible).Count > 1 Then
On Error Resume Next
'Si la feuille nommée par la valeur de ComboBox1 existe, on instancie dans Sh cette feuille
Set Sh = Sheets(Me.ComboBox1.Text)
On Error GoTo 0
'Si la feuille nommée par la valeur de ComboBox1 n'existe pas, Sh est vide (nothing)
If Sh Is Nothing Then
'On crée une nouvelle feuille qu'on nomme par la valeur de ComboBox1
Worksheets("Master").Copy After:=Sheets(Sheets.Count)
Set Sh = ActiveSheet
Sh.Name = Me.ComboBox1.Text
End If
'On copie le résultat issu du filtre dans la première ligne vide de la feuille Sh
.Range("A8:F" & Derlg).SpecialCells(xlCellTypeVisible).Copy Sh.Cells(Sh.Rows.Count, 1).End(xlUp)(2)
Set Sh = Nothing
End If
ActiveSheet.Select
Columns("A:C").ColumnWidth = 18
Columns("D:F").ColumnWidth = 10
Columns("G:I").ColumnWidth = 18

End If
'On supprime le filtre automatique précédent
.AutoFilterMode = False

Range("A14:I65536").Sort Key1:=Range("A14"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

End If

End With
Worksheets("Empl").Protect Password:="moncef"
Worksheets("Master").Protect Password:="moncef"
Worksheets("Master").Visible = False
ActiveSheet.Protect Password:="moncef"
Application.ScreenUpdating = True

ActiveSheet.Select
If Range("F4") = "Bourget" Then
Worksheets("Adresse").Visible = True
Worksheets("Adresse").Select
Range("A2:H2").Copy
Sheets("Bourget").Select
Range("F3").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("F4").Select
Worksheets("Adresse").Visible = False
Application.ScreenUpdating = True
End If
If Range("F4") = "Bussey" Then
Worksheets("Adresse").Visible = True
Worksheets("Adresse").Select
Range("A1:H1").Copy
Sheets("Bussey").Select
Range("F3").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("F4").Select
Worksheets("Adresse").Visible = False
Application.ScreenUpdating = True
End If

End Sub
 
Trier par date Trier par votes

Hippolite

XLDnaute Accro
Re : Macro Événementiel

Bonjour,
Il faut supprimer tous les Select qui ne servent qu'à ralentir.
Application.ScreenUpdating = True se met là où on a besoin de rafraîchir l'affichage de l'écran (en général à la fin de la macro)
Je ne pense pas que Worksheets("Adresse").Visible = True soit utile, je l'ai laissé en commentaire si tu as besoin de le rétablir (je n'ai pas excel sous la main pour vérifier).
Pour une meilleure visibilité, on pourrait aussi utiliser Select Case à la place de If.
VB: 
.
.
.
'Application.ScreenUpdating = True

If ActiveSheet.Range("F4") = "Bourget" Then
	'Worksheets("Adresse").Visible = True
	Worksheets("Adresse").Range("A2:H2").Copy
	Sheets("Bourget").Range("F3").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
	SkipBlanks:= False, Transpose:=True
	Range("F4").Select
	'Worksheets("Adresse").Visible = False
ElseIf ActiveSheet.Range("F4") = "Bussey" Then
	'Worksheets("Adresse").Visible = True
	Worksheets("Adresse").Range("A1:H1").Copy
	Sheets("Bussey").Range("F3").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
	SkipBlanks:= False, Transpose:=True
	Range("F4").Select
	'Worksheets("Adresse").Visible = False
End If
Application.ScreenUpdating = True
End Sub
A+
 
Dernière édition:
Vote positif 0 Vote négatif

Gorfael

XLDnaute Barbatruc
Re : Macro Événementiel

Salut duplaly et le forum
Utilises les balises de code (icone # en mode avancé), ce serait plus lisible
Code: 
Private Sub ComboBox1_Change()
Dim Derlg As Long, DD As Long, DF As Long
Dim Sh As Worksheet

Worksheets("Empl").Unprotect Password:="moncef"
Worksheets("Master").Unprotect Password:="moncef"
Worksheets("Master").Visible = True
Application.ScreenUpdating = False

With Sheets("Empl")
    .AutoFilterMode = False
    Derlg = .Range("A" & .Rows.Count).End(xlUp).Row
    If Me.ComboBox1.Value <> "" Then
        DD = CLng(Me.DTPicker1.Value)
        DF = CLng(Me.DTPicker2.Value)
        If DF > DD Then
            .Range("A7:J" & Derlg).AutoFilter field:=1, Criteria1:=">=" & DD, Criteria2:="<=" & DF, Operator:=xlAnd
            .Range("A7:H" & Derlg).AutoFilter field:=8, Criteria1:=Me.ComboBox1.Text
            If .Range("A7:A" & Derlg).SpecialCells(xlCellTypeVisible).Count > 1 Then
                On Error Resume Next
                Set Sh = Sheets(Me.ComboBox1.Text)
                On Error GoTo 0
                If Sh Is Nothing Then
                    Worksheets("Master").Copy After:=Sheets(Sheets.Count)
                    Set Sh = ActiveSheet
                    Sh.Name = Me.ComboBox1.Text
                End If
                .Range("A8:F" & Derlg).SpecialCells(xlCellTypeVisible).Copy Sh.Cells(Sh.Rows.Count, 1).End(xlUp)(2)
                Set Sh = Nothing
            End If
            Columns("A:C").ColumnWidth = 18
            Columns("D:F").ColumnWidth = 10
            Columns("G:I").ColumnWidth = 18
        End If
        .AutoFilterMode = False
        Range("A14:I65536").Sort Key1:=Range("A14"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    End If
End With
Worksheets("Empl").Protect Password:="moncef"
Worksheets("Master").Protect Password:="moncef"
Worksheets("Master").Visible = False
ActiveSheet.Protect Password:="moncef"

Select Case [F4]
    Case "Bourget"
        Worksheets("Adresse").Visible = True
        Worksheets("Adresse").Range("A2:H2").Copy
        Sheets("Bourget").Range("F3").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=True
        Range("F4").Select
        Worksheets("Adresse").Visible = False
    Case "Bussey"
        Worksheets("Adresse").Visible = True
        Worksheets("Adresse").Range("A1:H1").Copy
        Sheets("Bussey").Range("F3").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
        Range("F4").Select
        Worksheets("Adresse").Visible = False
End Select
Application.ScreenUpdating = True
End Sub
J'ai juste mis en forme et supprimé les commentaires, mais n'ai pas testé.
Les commentaires sont utiles. Mais trop d'infos tue l'info.
J'ai aussi supprimé l'instruction "ActiveSheet.Select". Je te laisse méditer sur son utilité
mais je ne suis pas certain de la macro événementiel que j'ai rajoutée à la fin du premier macro.
Cliquez pour agrandir...
On doit pas avoir la même définition d'une "macro évènementielle".
Pour moi, une macro évènementielle est une macro qui se lance de manière automatique quand l'évènement se produit. Là, le seul évènement qui lance la macro est le changement de la combobox1.

Si c'est un changement de la valeur de F4, il faut utiliser, dans le module lié à la feuille
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(0, 0) = "F4" Then
    'traitement de F4
End If
End Sub
Le code n'est qu'une indication. On peut utiliser n'importe quel différenciateur pour s'assurer que target (variable système de type plage mis à jour par excel et contenant la dernière plage étant sortie du mode édition) correspond bien à F4.
Je n'ai pas fait le code, ne connaissant pas le but réel à atteindre, mais...
- utiliser des select/selection ne fait, en général, que ralentir le code
- utiliser "if... end if" n'est utile que dans le cadre d'un test à deux réponses. S'il y en a plus, on peut utiliser "If...ElseIf...End if". Personnellement, je préfère utiliser "Select Case".
A+
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

C
  • Question
Microsoft 365 erreur d'execussion 6 - depassement de capacite
Réponses
2
Affichages
105
CARO13
C
U
  • Question
Autres incorporer une macro dans une autre macro
Réponses
5
Affichages
258
Phil69970
M
  • Question
Microsoft 365 Erreur sur mon Code VBA
Réponses
2
Affichages
251
Gégé-45550
L
  • Question
XL 2021 Comment utiliser la colonne d'une adresse en Private Sub - svp ?
Réponses
3
Affichages
374
vgendron
  • Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
763
Nicolas JACQUIN
M
  • Question
XL 2010 Demande de quantité d'un produit dans un magasin spécifique selon la date la plus ancienne
2
Réponses
21
Affichages
1 K
Mody200
M
M
  • Résolu(e)
XL 2016 Amélioration de code
Réponses
3
Affichages
478
M@xu3L
M
S
  • Question
XL 2021 Afficher et masquer des colonnes
Réponses
3
Affichages
323
job75
P
  • Résolu(e)
XL 2010 Réduire la macro
Réponses
2
Affichages
424
Panda79360
P
P
  • Question
XL 2019 Select Case 3 conditions imbriquées avec 2 variables
2
Réponses
20
Affichages
931
Dranreb
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…