Simplification de code

Créer une discussion
Répondre
  • Initiateur de la discussion Initiateur de la discussion rounil09
  • Date de début Date de début

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
rounil09

rounil09

XLDnaute Occasionnel
Bonjour la liste,
Soit un tableau de 17 colonnes et de 3 000 lignes (pour l’instant)
Le code suivant, qui sélectionne (en fonction de la valeur de cellules) des Noms et Prénoms successivement dans plusieurs colonnes de la feuille Liste_EP et les colle sur la feuille BD_CE , fonctionne.

Pour une meilleure lisibilité et pour gagner en temps de calcul, je cherche à le simplifier, en particulier les répétitions de code que l’on peut remarquer entre les lignes 1er membre et 4ème membre.

Cela me parait impossible avec la fonction AutoFilter que j’utilise.
Je n’arrive pas à m’en sortir avec la fonction Find ou autre, malgré l’aide en ligne du site.
Quelqu’un pourrait-il me mettre sur la bonne voie ?

Sub BD_CE()

Application.ScreenUpdating = False 'fige l'écran
Application.Calculation = xlCalculationManual

Dim Cellule As Range

'Déprotège les feuilles avec mot de passe
Dim f As Worksheet
For Each f In ActiveWorkbook.Worksheets
f.Unprotect "7525"
Next

'Base de la macro : 1000 EP maxi par C.E. Nettoyage de l'écran,
[A10:Q1000].Clear

Sheets("Liste_EP").Select

If Range("A2").Value = 0 Then
Application.Goto Sheets("BD_CE").Range("A15:M15")
MsgBox "Vous n'avez pas sélectionné de C.E. dans la liste déroulante"
GoTo 1
Else
'Filtrer la base de données sur le champ I (8 --> Nom, Prénom du C.E.) avec valeur de la cellule A3
Sheets("Liste_EP").Select
Selection.AutoFilter
ActiveSheet.Range("$B$1:$R$100000").AutoFilter Field:=8, Criteria1:=Range("A3").Value

'Se caler dernière cellule vide de la colonne B, sélectionner jusqu'à colonne R, copier la sélection
Range("B" & Rows.Count).End(xlUp).Select
Range("B2:R2", ActiveCell).Select
Selection.Copy

Application.Goto Sheets("BD_CE").Range("A10")
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
Application.Goto reference:=Range("A1"), Scroll:=True

'Oter le filtre du champ 8 de la BD en cochant 'sélectionner tout' (codé par Down=-12)
Sheets("Liste_EP").Select
ActiveSheet.Range("$B$1:$R$100000").AutoFilter Field:=8
ActiveWindow.SmallScroll Down:=-12
End If

'Rechercher Membres des commissions

'1er membre
Sheets("Liste_EP").Select
'Filtrer la base de données sur le champ 13 (1er membre)
ActiveSheet.Range("$B$1:$R$100000").AutoFilter Field:=13, Criteria1:=Range("A3").Value
'Se caler dernière cellule vide de la colonne B,
Range("B" & Rows.Count).End(xlUp).Select
If ActiveCell = Range("B1").Value Then
[A1].Select
Else
Range("B2:R2", ActiveCell).Select
Selection.Copy
'Se caler dans BD_EP et copier la sélection
Sheets("BD_CE").Select
'Se caler dernière cellule vide de la colonne A,
Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
End If

'2ème membre
'Oter le filtre du champ 13 de la BD en cochant 'sélectionner tout' (codé par Down=-12)
Sheets("Liste_EP").Select
ActiveSheet.Range("$B$1:$R$100000").AutoFilter Field:=13
ActiveWindow.SmallScroll Down:=-12
Sheets("Liste_EP").Select
'Filtrer la base de données sur le champ 14 (2ème membre)
ActiveSheet.Range("$B$1:$R$100000").AutoFilter Field:=14, Criteria1:=Range("A3").Value
'Se caler dernière cellule vide de la colonne B, sélectionner jusqu'à colonne R, copier la sélection
Range("B" & Rows.Count).End(xlUp).Select
If ActiveCell = Range("B1").Value Then
[A1].Select
Else
Range("B2:R2", ActiveCell).Select
Selection.Copy
'Se caler dans BD_EP et copier la sélection
Sheets("BD_CE").Select
'Se caler dernière cellule vide de la colonne A,
Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
End If

'3ème membre
'Oter le filtre du champ 14 de la BD en cochant 'sélectionner tout' (codé par Down=-12)
Sheets("Liste_EP").Select
ActiveSheet.Range("$B$1:$R$100000").AutoFilter Field:=14
ActiveWindow.SmallScroll Down:=-12
Sheets("Liste_EP").Select
'Filtrer la base de données sur le champ 15 (3ème membre)
ActiveSheet.Range("$B$1:$R$100000").AutoFilter Field:=15, Criteria1:=Range("A3").Value
'Se caler dernière cellule vide de la colonne B, sélectionner jusqu'à colonne R, copier la sélection
Range("B" & Rows.Count).End(xlUp).Select
If ActiveCell = Range("B1").Value Then
[A1].Select
Else
Range("B2:R2", ActiveCell).Select
Selection.Copy
'Se caler dans BD_EP et copier la sélection
Sheets("BD_CE").Select
'Se caler dernière cellule vide de la colonne A,
Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
End If

'4ème membre
'Oter le filtre du champ 15 de la BD en cochant 'sélectionner tout' (codé par Down=-12)
Sheets("Liste_EP").Select
ActiveSheet.Range("$B$1:$R$100000").AutoFilter Field:=15
ActiveWindow.SmallScroll Down:=-12
'Filtrer la base de données sur le champ 16 (4ème membre)
ActiveSheet.Range("$B$1:$R$100000").AutoFilter Field:=16, Criteria1:=Range("A3").Value
'Se caler dernière cellule vide de la colonne B, sélectionner jusqu'à colonne R, copier la sélection
Range("B" & Rows.Count).End(xlUp).Select
If ActiveCell = Range("B1").Value Then
[A1].Select
Else
'Se caler dans BD_EP et copier la sélection
Range("B2:R2", ActiveCell).Select
Selection.Copy
Sheets("BD_CE").Select
'Se caler dernière cellule vide de la colonne A,coller la sélection
Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
End If

1 'Nettoyage écran et message si aucune E.P. enregistrée
Sheets("BD_CE").Select
If Range("A10").Value = "Chrono EP Global" Then
[A10:Q1000].Clear
With Sheets("Param")
MsgBox .Range("J28") & " " & ": aucune activité n'a été enregistrée pour ce C.E."
End With
End If

'Désactiver tous les filtres de la page Liste_EP
With Sheets("Liste_EP")
If .FilterMode = True Then .ShowAllData
End With

Application.Goto reference:=Range("A1"), Scroll:=True
Sheets("Param").Select
[I28].Value = 0
Sheets("BD_CE").Select
'Zoom de l'écran BD_CE
Range("A15:M15").Select
ActiveWindow.Zoom = True
Application.Goto reference:=Range("A1"), Scroll:=True


'Protège les feuilles avec mot de passe
For Each f In ActiveWorkbook.Worksheets
f.Protect "7525", True, True, True
Next

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True 'défige l'écran

End Sub
 
Trier par date Trier par votes
Re : Simplification de code

Salut Rounil09

Sans fichier, pas simple, mais essaye ce code
VB: 
Option Explicit

Sub BD_CE()
  Dim Cellule As Range
  Dim Membre As Integer
  Dim TabCol() As String
  Dim Dlig As Long
  '
  Application.ScreenUpdating = False  'fige l'écran
  Application.Calculation = xlCalculationManual
  'Déprotège les feuilles avec mot de passe
  Dim f As Worksheet
  For Each f In ActiveWorkbook.Worksheets
    f.Unprotect "7525"
  Next
  '
  ' Définition des colonnes de filtre
  TabCol = Split("8,13,14,15", ",")
  'Base de la macro : 1000 EP maxi par C.E. Nettoyage de l'écran,
  [A10:Q1000].Clear


  If Sheets("Liste_EP").Range("A2").Value = 0 Then
    With Sheets("BD_CE")
      .Activate
      .Range("A15:M15").Select
      MsgBox "Vous n'avez pas sélectionné de C.E. dans la liste déroulante"
      If .Range("A10").Value = "Chrono EP Global" Then
        .Range("A10:Q1000").Clear
        MsgBox Sheets("Param").Range("J28") & " " & ": aucune activité n'a été enregistrée pour ce C.E."
      End If
    End With
    'Désactiver tous les filtres de la page Liste_EP
    With Sheets("Liste_EP")
      If .FilterMode = True Then .ShowAllData
    End With
    Sheets("Param").Range("I28").Value = 0
  Else
    'Filtrer la base de données sur le champ I (8 --> Nom, Prénom du C.E.) avec valeur de la cellule A3
    'Rechercher Membres des commissions
    '1er membre , 2ème membre, 3ème membre, 4ème membre
    With Sheets("Liste_EP")
      For Membre = 1 To 4
        .Range("$B$1:$R$100000").AutoFilter Field:=Val(TabCol(Membre)), Criteria1:=Range("A3").Value
        'Sélectionner de la cellule B2 à R et dernière ligne remplie
        Dlig = Sheets("BD_CE").Range("A" & Rows.Count).End(xlUp).Row
        .Range("B2:R" & Range("R" & Rows.Count).End(xlUp).Row).Copy Destination:=Sheets("BD_CE").Range("A" & Dlig + 1)
        'Oter le filtre du champ de la BD
        .Range("$B$1:$R$100000").AutoFilter Field:=Val(TabCol(Membre))
      Next Membre
    End With
  End If
  'Protège les feuilles avec mot de passe
  For Each f In ActiveWorkbook.Worksheets
    f.Protect "7525", True, True, True
  Next
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True  'défige l'écran  Else
End Sub

A+
 
Dernière modification par un modérateur:
Vote positif 0 Vote négatif
Re : Simplification de code

Le code plante sur Autofilter

With Sheets("Liste_EP")
For Membre = 1 To 4
.AutoFilter
.Range("$B$1:$R$100000").AutoFilter Field:=Val(TabCol(Membre)), Criteria1:=Range("A3").Value

J'ai le message :
'Erreur d'execution 438'
Proprieté ou methode non gérée par cet objet
 
Vote positif 0 Vote négatif
Re : Simplification de code

Grrrrr !!!!

Je plante toujours.

Je supprimé autofilter qui me parraissait superflu car repris en ligne qui suit.
Dans ce cas la macro passe, mais plante sur le 'paste' (ligne en rouge),
avec le message : 'Erreur d'execution 438'
Proprieté ou methode non gérée par cet objet

Je suis à deux lignes du terme... et pas possible de décoincer.

Merci pour un dernier petit coup de pouce.

With Sheets("Liste_EP")
For Membre = 1 To 4
'.AutoFilter
.Range("$B$1:$R$100000").AutoFilter Field:=Val(TabCol(Membre)), Criteria1:=Range("A3").Value
'Se caler dernière cellule vide de la colonne B, sélectionner jusqu'à colonne R, copier la sélection
Range("B2:R" & Rows.Count).End(xlUp).Copy
DLig = Sheets("BD_CE").Range("A" & Rows.Count).End(xlUp).Row
Sheets("BD_CE").Range("A" & DLig + 1).Paste 'Oter le filtre du champ 8 de la BD en cochant 'sélectionner tout' (codé par Down=-12)
.Range("$B$1:$R$100000").AutoFilter Field:=Val(TabCol(Membre))
Next Membre
End With
 
Vote positif 0 Vote négatif
Re : Simplification de code

Salut Rounil09

C'est le problème quand on ne joint pas de fichier, on ne peut pas tester 🙄

Mais il y avait au moins 2 erreurs
1) ".Autofilter" est en trop
2) On ne peut pas faire un "Paste" sur un objet Range, uniquement sur l'objet Sheet

Code corrigé sur le Post#2

A+
 
Vote positif 0 Vote négatif
Re : Simplification de code

Je jette l’éponge.
J’ai bataillé toute l’après-midi pour comprendre et modifier le code que m’a proposé, à 2 reprises, BRUNOM45.
Mais toujours sans succès. Je suis encore planté, cette fois sur la ligne :
.Range("$B$1:$R$100000").AutoFilter Field:=Val(TabCol(Membre)), Criteria1:=Range("A3").Value

Je joins le fishier
Merci à l’âme bienveillante qui voudra bien s’y pencher.
 

Pièces jointes

Vote positif 0 Vote négatif
Re : Simplification de code

Bonsoir Rounil09

C'est tellement plus simple quand on a le fichier 🙄😀

J'ai laissé traîner bon nombre de bugs effectivement 😱

Regarde si cela te convient mieux

A+
 

Pièces jointes

Vote positif 0 Vote négatif
Re : Simplification de code

Merci à nouveau BRUNOM45.
Le code fonctionne à un détail prés sur le fichier joint (noitoirement allégé)
Par contre, sur mon fichier origine je replante à la même ligne !!!
Je vais voir demain soir si je peux avancer seul (pas possible avant).
Bonne soirée et peut-être à ++
 
Vote positif 0 Vote négatif
Re : Simplification de code

Bonjour la liste des mordus d’Excel,

Je touche….presque au but.
Je suis venu à bout des quelques petits problèmes qui subsistaient mais Il me reste un dernier dysfonctionnement à régler.
Le but de la macro est de récupérer toute l’activité d’un individu donné. Il s’agit d’extraire par filtrages successifs d’une BD toutes les lignes qui le concernent.
Hors, si une colonne contient deux fois le Nom du même individu, il n’est récupéré que la dernière ligne le concernant. C’est valable pour toutes les colonnes filtrées.

Par exemple,
pour l’individu ‘CLAR Robert’ il manque la ligne 13 de la BD (en colonne 8).
Pour l’individu ‘SUTR Jean-Luc’ il manque la ligne 1 de la BD . (en colonne 8).
Pour l’individu ‘HER Jules’ il manque la ligne 11 de la BD . (en colonne 13).
Nota : Les n° de lignes à considérer sont portés en colonne A

Je ne vois bien pas où doit porter la correction.
Toutes les solutions que j’ai testées ont échouées…

Voir le fichier joint.
 

Pièces jointes

Vote positif 0 Vote négatif
Re : Simplification de code

Bonsoir Rounil09

Il faut changer cette partie du code
VB: 
        If DLigL >= 2 Then 
         NLigB = Sheets("BD_CE").Range("A" & Rows.Count).End(xlUp).Row + 1
          .Range("B" & DLigL & ":R" & DLigL).Copy Destination:=Sheets("BD_CE").Range("A" & NLigB)
          Sheets("BD_CE").Range("A" & NLigB & ":Q" & NLigB).Copy
          Sheets("BD_CE").Range("A" & NLigB).PasteSpecial Paste:=xlPasteValues
        End If
Par
VB: 
        If DLigL >= 2 Then
          NLigB = Sheets("BD_CE").Range("A" & Rows.Count).End(xlUp).Row + 1
          .Range("B2:R" & DLigL).Select
          .Range("B2:R" & DLigL).Copy Destination:=Sheets("BD_CE").Range("A" & NLigB)
          NLigB = Sheets("BD_CE").Range("A" & Rows.Count).End(xlUp).Row
          Sheets("BD_CE").Range("A10:Q" & NLigB).Copy
          Sheets("BD_CE").Range("A10").PasteSpecial Paste:=xlPasteValues
        End If
Effectivement la copie se faisait uniquement sur la dernière ligne filtrée
au lieu de commencer par la 2ème

A+
 
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

arck
  • Résolu(e)
XL 2019 macro avec fonction copié coller si rempli par la macro
Réponses
12
Affichages
271
AtTheOne
AtTheOne
arck
  • Résolu(e)
XL 2019 Renvoyé à la ligne suivante si la ligne demandé n'est pas libre
Réponses
9
Affichages
144
Phil69970
Phil69970
ph.vanne
  • Question Question
Autres fenêtre "Publication"
Réponses
10
Affichages
547
ph.vanne
ph.vanne
H
  • Résolu(e)
XL 2016 Copier cellule dans un autre onglets
2
Réponses
16
Affichages
541
Phil69970
Phil69970
richardlion
  • Question Question
XL 2016 copier valeur actuel
2
Réponses
18
Affichages
316
sylvanu
sylvanu
KTM
  • Question Question
XL 2016 Filtrer plage via le contrôle ActiveX : combobox
Réponses
7
Affichages
275
KTM
KTM
C
  • Question Question
Microsoft 365 Enregistrer via VBA sans ouvrir fichier
Réponses
9
Affichages
359
cdric78
C
M
  • Question Question
XL 2021 VBA Excel Erreur 2023
Réponses
2
Affichages
283
MICHIS
M
micie1509
  • Résolu(e)
XL 2021 Exécuter une macro sur plusieurs feuilles
Réponses
9
Affichages
451
micie1509
micie1509
M
  • Question Question
Microsoft 365 deux macros succesives et un bouton
2
Réponses
17
Affichages
1 K
MICHAEL
M
S
  • Résolu(e)
XL 2013 Questions déjà traitée ici mais... (Insérer cellule dans nom de PDF)
Réponses
10
Affichages
260
StéphaneDeLà
S
T
  • Résolu(e)
Microsoft 365 VBA Exporter une sélection de plages nommées au format PDF
Réponses
12
Affichages
505
tnion
T
B
  • Question Question
XL 2019 Dans une macro de démarrage de fichier masquer le code par des Astérix ou point
Réponses
3
Affichages
200
sylvanu
sylvanu
N
  • Résolu(e)
Microsoft 365 Macro copier/coller entre deux tableaux structurés
3 4 5
Réponses
66
Affichages
2 K
job75
job75
David Aubert
Optimisation de code VBA
Réponses
5
Affichages
148
Cléa
Cléa
Z
  • Résolu(e)
Microsoft 365 Problème de combinaison entre fonctions "If Then Else" et "SelectCase"
Réponses
11
Affichages
712
Zonmé
Z
R
  • Résolu(e)
XL 2019 creer une macro pour copier des info d un onglet a un autre dans le meme classeur
Réponses
4
Affichages
656
robpellan52
R
P
  • Question Question
XL 2021 Ajout/adaptation de code VBA sur feuille qui en contient déjà
Réponses
3
Affichages
156
Pierreavecunp
P
X
  • Question Question
XL 2021 VBA Filtre dans Tableau
Réponses
3
Affichages
339
Xxaann
X
V
  • Question Question
XL pour MAC outil coller le contenu du presse papier
Réponses
2
Affichages
639
Valter
V
Retour