Simplifier une Macro

Bonjour à tous et bonne ou meilleur année 2019 à tous .

J'aurais besoin de vos lumières pour simplifier une soixantaine de macros basé sur le même code.

J'ai un classeur dans lequel un tableau reprend le travail de plusieurs équipes,lignes, etc... et ce pour une année.

Pour simplifier les démarches de recherche et filtrage, j'ai créé des boutons auxquels j'ai associé une macro pour chaque équipe ou ligne de travail etc...

la macro fonctionne parfaitement néanmoins j'aurais voulu savoir si je pouvais la simplifier car ça fait de beau pavé par macro et aussi j'aurai voulu faire en sorte qu'elle ne prenne que le mois recherché dans le filtrage car avec l'année ça pose problème.

voici un bout de ma macro

Sub EQUIPE23()
'
' EQUIPE23 Macro

' Transferer des données présentes dans la feuille "BASE DE SAISIE" concernant l'équipe 23 dans la feuille "EQUIPES" en fonction d'un choix du menu déroulant et dont sa cellule lié se situe dan la feuille "MACRO"

    ' Pour transferer les données du mois de Janvier
    Application.ScreenUpdating = False
    Sheets("MACRO").Select
    If (Range("B7")) = 1 Then
    Sheets("BASE DE SAISIE").Select
    ActiveSheet.Range("$A$23:$AP$5475").AutoFilter Field:=1
    ActiveSheet.Range("$A$23:$AP$5475").AutoFilter Field:=1, Criteria1:="23"
    ActiveSheet.Range("$A$23:$AP$5475").AutoFilter Field:=3
    ActiveSheet.Range("$A$23:$AP$5475").AutoFilter Field:=3, Operator:= _
        xlFilterValues, Criteria2:=Array(1, "1/31/2018", 1, "1/01/2018")
    Range("D3:AG19").Select
    Range("D19").Activate
    Selection.Copy
    Sheets("EQUIPES").Select
    Range("D3").Select
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    Range("C15").Select
    End If

    ' Pour transferer les données du mois de Février
    If (Range("B7")) = 2 Then
    Sheets("BASE DE SAISIE").Select
    ActiveSheet.Range("$A$23:$AP$5475").AutoFilter Field:=1
    ActiveSheet.Range("$A$23:$AP$5475").AutoFilter Field:=1, Criteria1:="23"
    ActiveSheet.Range("$A$23:$AP$5475").AutoFilter Field:=3
    ActiveSheet.Range("$A$23:$AP$5475").AutoFilter Field:=3, Operator:= _
        xlFilterValues, Criteria2:=Array(1, "2/28/2018", 1, "2/1/2018")
    Range("D3:AG19").Select
    Range("D19").Activate
    Selection.Copy
    Sheets("EQUIPES").Select
    Range("D3:AG19").Select
    Range("D19").Activate
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    Range("C15").Select
    End If

    ..........

    ' Pour transferer les données du mois de Décembre
    If (Range("B7")) = 12 Then
    Sheets("BASE DE SAISIE").Select
    ActiveSheet.Range("$A$23:$AP$5475").AutoFilter Field:=1
    ActiveSheet.Range("$A$23:$AP$5475").AutoFilter Field:=1, Criteria1:="23"
    ActiveSheet.Range("$A$23:$AP$5475").AutoFilter Field:=3
    ActiveSheet.Range("$A$23:$AP$5475").AutoFilter Field:=3, Operator:= _
        xlFilterValues, Criteria2:=Array(1, "12/31/2018", 1, "12/1/2018")
    Range("D3:AG19").Select
    Range("D19").Activate
    Selection.Copy
    Sheets("EQUIPES").Select
    Range("D3:AG19").Select
    Range("D19").Activate
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    Range("C15").Select
    End If
    Application.ScreenUpdating = True

End Sub

Bien évidemment je n'ai pas mis les 12 mois mais le principe est là.

Aujourd'hui nous sommes en 2019 et si j'applique cette macro elle ne fonctionnera pas normalement vu que la macro est codée sur 2018.

Merci d'avance pour les propositions que vous pourriez m'apporter.

Bonjour Michael,

Est-ce que tu peux fournir ton fichier ?

Ca serait plus facile pour les forumeurs.

Cordialement

Bonjour ddetp88.

Je suis en déplacement et je reviens demain.

Dans ce fichier j'ai pas mal de chose qui doivent rester confidentiel donc si c'est vraiment nécessaire je verrai comment je peux faire.

Merci

Le mieux c'est de le limiter ou de reproduire le fichier pour avoir un exemple sur lequel travailler.

Si tu peux l'anonymer c'est encore le mieux.

Bonne journée

Bonjour ddetp88,

alors j'ai recréer un fichier dans lequel il y a les principaux codes qui demande à être simplifier.

tu peux fournir le mot de passe du vba ?

tous les mots de passe dans le fichier c'est EP

Bonjour Michael,

J'ai eu quelques absences et quand je m'y suis remis j'ai rencontré des difficultés avec le filtrage des dates.

Enfin c'est plus léger que ça ne l'était

Il reste certaines choses qui restent encore incomprises notamment le masquage des feuilles.

Je n'ai pas trouvé sur la feuille d'accueil un bouton pour les afficher. J'ai donc mis en remarque les deux procédures ligne1 et ligne2 pour ne pas être ennuyé. Idem pour le vba il faudra remettre le mdp en place.

Bonne suite à ton projet.

Cordialement

Bonjour ddetp88,

Pas de problème pour l'absence je ne suis pas pressé vu que mon fichier fonctionne et merci pour l'aide.

Concernant le masquage des feuilles c'est normal car je ne souhaite pas que certaines feuilles soit vu par certaines personnes.

Concernant les boutons c'est normal il n'y en a pas car seul les personnes qui savent qu'il y a des feuilles cachées savent quelle macro exécuter pour les afficher, mais désolé d'avoir oublié de le dire...

je vais voir le fichier et je te tiens au jus

Merci.

Alors en effet le filtre de mon fichier ne fonctionne pas( je ne comprends pas) .

sinon je pense avoir eu ton code en entier car mon mac m'annonce qu'une partie du contenu de ce classeur n’est pas prise en charge par ma version d’Excel. J'écris ça parce que je n'arrive pas à défiler de haut en bas dans les codes( que ce soit ton code ou le mien)

néanmoins vu que je vois le End Sub, je suppose qu'il est entier.

Si c'est le cas, c'est le type de simplification que je recherchais. passer de environ 100 lignes de code à environ 15, parfait.

Si j'ai bien compris ton code, il suffit de saisir l'année et l'équipe ou la ligne. Alors là je ne souhaite pas saisir l'année. je m'explique...mon but est de faire un classeur par an mais il est aussi de faire en sorte que ma macro s'adapte à l'année de la date figurant en colonne "C" .

quelque chose du type :

année="aaaa" présent dans column("c"), dans les variables( l'idée est là mais la formule et syntaxe non)

Suite à ça ton code est capable de savoir quel est la feuille active pour savoir si c'est l'équipe ou la ligne puis de copier/coller les infos filtrées de la base de saisie vers le tableau de la feuille active.

Alors si c'est ça....oui! Mais je ne sais pas si tu avais vu mes codes pour les lignes. Celles-ci alimentent 2 feuilles. Le code de la ligne 9 copie les données de la base de saisie et les transfert sur la feuille active en D3 et aussi sur la feuille "Ligne 1" en D22.

j'ai vu une ligne de code UBound...je ne connais pas, est ici que je saisie D22 ?

Sinon je n'ai pas vu l'intérêt du menu déroulant concernant les mois présent dans ton tableau jaune"Données de filtrage" ou alors, je n'ai pas trouvé la ligne dans le code permettant de comprendre son intérêt.

comment se fait la liaison entre ton menu déroulant et ton code?

Merci pour ton aide ddetp88.

cordialement

Bonjour Michael

J'ai tenu compte de tes remarques pour affiner le code.

Par ailleurs, la feuille macro ne sert plus qu'à récupérer les mois. Les combobox des feuilles equipes et lignes déclenche le code.

J'ai profité de cette retouche pour créer des listes de validations dynamiques. elles se créaient à la sélection de la feuille. Merci au passage à JJ Boisgontier qui est à l'origine de ce code.

Donc désormais tu choisis dans le cadre jaune l'équipe le mois et le ou les feuilles se mettent à jour s'il y a des données à filtrer. Dans le cas contraire tu as un message t'avertissant qu'il n'y a pas de données à filtrer.

Teste et dis moi rapidement car à partir de la semaine prochaine, je n'aurai plus de temps libre reprise du boulot oblige.

Bonne journée

Ps

j'ai modifié les dates pour pouvoir tester le fichier.

J'ai supprimé des mises en forme qui alourdissent d'une manière conséquence ton fichier.

bonjour ddetp88,

Merci à toi et à JJ Boisgontier pour votre aide mais j'ai un souci, je n'arrive pas à afficher le code en entier la dernière ligne visible est Exit Sub. Impossible de défiler plus bas que se soit avec le curseur les flèches du clavier ou barre de défilement.

J'ai toujours ce même souci concernant la prise en charge de la version excel, chose que je ne comprends pas car j'ai office 365 vers16.20.

Ce n'est qu'une hypothèse mais je pense que le problème vient de la version mac.

Résultat je n'arrive pas à faire fonctionner la macro.

A ton avis est ce un problème du au fait que se soit un excel sous mac?

là en gros le menu déroulant concernant le mois ne fonctionne pas.

celui de l'équipe m'affiche les équipes mais je ne peux pas les sélectionner

et la ligne je n'ai que la 9 pas la 3

une idée?

cordialement

re,

Voici le code dans son intégralité:

Public wb As Worksheet, wf As Worksheet
Option Explicit
Sub EcritureDonnees(Mois%)
'déclaration des variables
Dim d%, nf$, Eq$, Plage
Set wb = Sheets("BASE DE SAISIE") '..................................................Instanciation
nf = ActiveSheet.Name: Set wf = Sheets(nf) '.........................................Instanciation
wf.Range("D3:AG19").ClearContents '..................................................effecer la plage de cellules

Application.ScreenUpdating = False '.................................................désactive les màj écran

Eq = wf.[B8] '.......................................................................Equipe ou axe
On Error GoTo Message1 '.............................................................si une erreur se produit
If wb.FilterMode = True Then wb.ShowAllData '........................................suppression des filtres s'ils existent
If nf = "EQUIPES" Then '.............................................................si l'info vient de la feuille équipes
   With wf '.........................................................................avec wf
      wb.Range("$A$23:$AP$5475").AutoFilter Field:=1, Criteria1:=Eq '................1er filtre en colonne 1
      d = Day(DateSerial(Year(Date), 4, 1) - 2) '.....................................recherche du dernier jour
      wb.Range("$A$23:$AP$5475").AutoFilter Field:=3, Operator:= _
      xlFilterValues, Criteria2:=Array(1, Mois & "/" & d & "/" & Year(Date)) '.......2ème filtre sur les date du mois
   End With
   Plage = wb.[D3:AG19].Value '......................................................copie de la plage
   wf.[D3].Resize(UBound(Plage, 1), UBound(Plage, 2)) = Plage '......................colle les valeurs

ElseIf nf = "LIGNES" Then '..........................................................si l'information vien =t de la feuille lignes
   With wf '.........................................................................avec wf
      wb.Range("$A$23:$AP$5475").AutoFilter Field:=5, Criteria1:=Eq '................1er filtre que la colonne 5
      d = Day(DateSerial(Year(Date), 4, 1) - 2) '.........................................recherche du dernier jour
      wb.Range("$A$23:$AP$5475").AutoFilter Field:=3, Operator:= _
      xlFilterValues, Criteria2:=Array(1, Mois & "/" & d & "/" & Year(Date)) '.......2ème filtre sur les date du mois
      Plage = .[D3:AG19].Value '.....................................................copie de la plage
      .[D3].Resize(UBound(Plage, 1), UBound(Plage, 2)) = Plage '.....................colle les valeurs
   End With
   If Eq = "3" Then
      With Sheets("Ligne 1")
         Plage = wb.[D3:AG19].Value '.................................................copie de la plage
         .Range("D3:AG19").ClearContents '............................................effacer la plage de cellules
         .[D3].Resize(UBound(Plage, 1), UBound(Plage, 2)) = Plage '...................colle les valeurs feuille ligne 1
      End With
   End If
   If Eq = "9" Then
      With Sheets("Ligne 1")
         Plage = wb.[D3:AG19].Value '.................................................copie de la plage
         .Range("D22:AG38").ClearContents '...........................................effacer la plage de cellules
         .[D22].Resize(UBound(Plage, 1), UBound(Plage, 2)) = Plage '..................colle les valeurs feuille ligne 1
      End With
   End If
End If
Application.ScreenUpdating = True '..................................................désactive les màj écran
Exit Sub

Message1:
MsgBox "Aucune donnée filtrée.", vbInformation, "INFORMATION"
If wb.FilterMode = True Then wb.ShowAllData '........................................suppression des filtres s'ils existent

End Sub

Dans les feuilles c'est le même hormis les coordonnées des cellules pour la ligne a=.range("a24:a" & ...

Private Sub Cb_Lignes_Change()
Sheets("Ligne 1").[B18,B37] = Cb_Lignes.Value
'lance la procédure EcritureDonnees
Call EcritureDonnees(Cb_Lignes.ListIndex + 1)
End Sub

Private Sub Worksheet_Activate()
'site boisgontier
  Set d1 = CreateObject("Scripting.Dictionary")
  With Sheets("BASE DE SAISIE")
   a = .Range("E24:E" & .Range("E" & Rows.Count).End(xlUp).Row)
  End With
  For Each c In a
    d1(c) = ""
  Next c
  [B8].Validation.Delete
  [B8].Validation.Add xlValidateList, Formula1:=Join(d1.keys, ",")
End Sub

Pour ce qui est du mac je ne connais pas mais je sais qu'il y a des différences dans les procédures

et la ligne je n'ai que la 9 pas la 3

Là c'est peut être une erreur de ma part. Quand tu sélectionnes la feuille, la liste de validation se constitue.

Si la feuille est filtrée, la liste peut être fausse.

Je vais y remédier et te faire une version enregistrée en .xls pour office 2003 en espérant que ça fonctionnera. Il faut croiser les doigts.

@+

re,

et la ligne je n'ai que la 9 pas la 3

Il faut mettre cette ligne de code en plus:

If Sheets("BASE DE SAISIE").FilterMode = True Then Sheets("BASE DE SAISIE").ShowAllData

Dans les codes des feuilles Equipes et Lignes comme ceci:

Private Sub Worksheet_Activate()
If Sheets("BASE DE SAISIE").FilterMode = True Then Sheets("BASE DE SAISIE").ShowAllData
'site boisgontier
  Set d1 = CreateObject("Scripting.Dictionary")
  With Sheets("BASE DE SAISIE")
   a = .Range("A24:A" & .Range("A" & Rows.Count).End(xlUp).Row)
  End With
  For Each c In a
    d1(c) = ""
  Next c
  [B8].Validation.Delete
  [B8].Validation.Add xlValidateList, Formula1:=Join(d1.keys, ",")
End Sub

ça marche

Merci

Attention une erreur dans la procédure:

remplacer par

Plage = wb.[D3:AG19].Value '...................................................copie de la plage

Par ailleurs dans ta page base de saisie tu devrais modifier tes formules qui affiche #DIV/0!

Ca n'est pas très esthétique.

Exemple pour N18 tu peux remplacer ta formule par celle-ci

=SI(ESTERREUR(M18/K5);"";M18/K5)

J'attends tes remarques pour te poster la version corrigée du bug de la procédure principale

@+

Pour ma part l'esthetisme du fichier est un détail que je verrai plus tard mais en effet je reconnais que visuellement c'est plus reposant.

sinon ça ne fonctionne toujours pas.

j' ai un message d'erreur sur cette macro:

Private Sub Worksheet_Activate()
If Sheets("BASE DE SAISIE").FilterMode = True Then Sheets("BASE DE SAISIE").ShowAllData
'site boisgontier
  Set d1 = CreateObject("Scripting.Dictionary")
  With Sheets("BASE DE SAISIE")
   a = .Range("E24:E" & .Range("E" & Rows.Count).End(xlUp).Row)
  End With
  For Each c In a
    d1(c) = ""
  Next c
  [B8].Validation.Delete
  [B8].Validation.Add xlValidateList, Formula1:=Join(d1.keys, ",")
End Sub

ça met

erreur d'execution 429

Un composant Active X ne peut pas créer d'objet et l'erreur est sur la ligne

Set d1 = CreateObject("Scripting.Dictionary")

un peu perdu sur cette macro

Sur cette erreur, c'est la création du dictionnaire.

Je pense qu'il faut que tu coches une bibliothèque:

Microsoft office xx Object Library

xx correspond à ta version d'office

Exemple pour office 2016

Microsoft office 16 Object Library

Vois les bibliothèques cochées sur mon pc.

Cordialement

C'est déjà coché .

c'est hallucinant le temps que je perds sur des problèmes de compatibilités office windows/office mac car je pense vraiment que le problème vient de là.

mais si tu as une autre idée je prends

cordialement

Non pas d'autre idée.

Tu peux peut-être ouvrir un nouveau fil pour la compatibilité de la procédure. Celle où tu as un bug.

Bon courage.

Voici le fichier avec la ligne corrigée

Plage = wb.[D3:AG19].Value '...................................................copie de la plage