Simplification de code

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
C

Compte Supprimé 979

Guest
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
rounil09

rounil09

XLDnaute Occasionnel
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
rounil09

rounil09

XLDnaute Occasionnel
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
C

Compte Supprimé 979

Guest
Re : Simplification de code

Salut Rounil09

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

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
rounil09

rounil09

XLDnaute Occasionnel
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

  • Simplification code_ACE-2012-F.xlsm
    164.4 KB · Affichages: 28
Vote positif 0 Vote négatif
C

Compte Supprimé 979

Guest
Re : Simplification de code

Bonsoir Rounil09

C'est tellement plus simple quand on a le fichier :rolleyes::D

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

Regarde si cela te convient mieux

A+
 

Pièces jointes

  • Rounil09_Simplification code_ACE-2012-F.xlsm
    157.7 KB · Affichages: 30
  • Rounil09_Simplification code_ACE-2012-F.xlsm
    157.7 KB · Affichages: 31
  • Rounil09_Simplification code_ACE-2012-F.xlsm
    157.7 KB · Affichages: 31
Vote positif 0 Vote négatif
rounil09

rounil09

XLDnaute Occasionnel
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
rounil09

rounil09

XLDnaute Occasionnel
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

  • Rounil09_Simplification code_ACE-2012-F.xlsm
    154.2 KB · Affichages: 34
  • Rounil09_Simplification code_ACE-2012-F.xlsm
    154.2 KB · Affichages: 38
  • Rounil09_Simplification code_ACE-2012-F.xlsm
    154.2 KB · Affichages: 33
Vote positif 0 Vote négatif
C

Compte Supprimé 979

Guest
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

Discussions similaires

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
280
robpellan52
R
Z
  • Résolu(e)
Microsoft 365 Problème de combinaison entre fonctions "If Then Else" et "SelectCase"
Réponses
11
Affichages
253
Zonmé
Z
G
  • Résolu(e)
XL 2013 copier coller valeur d'une colonne dynamique
Réponses
13
Affichages
342
gwenn49
G
B
  • Question
XL 2013 Comment trier les nom des feuilles et fusionner leur tableaux dans une une autre feuille ?
Réponses
10
Affichages
217
Compte Supprimé 979
C
O
  • Question
XL 2010 aide sur code VBA collationnement de données
Réponses
10
Affichages
458
olivier388
O
Usine à gaz
  • Résolu(e)
XL 2021 Ecrire dans une une autre feuille
Réponses
3
Affichages
315
Usine à gaz
Usine à gaz
F
  • Question
Microsoft 365 Poursuivre ou pas la macro
Réponses
2
Affichages
196
Francky79
F
X
  • Question
XL 2016 Copier à partir de la dernière ligne renseignée.
Réponses
8
Affichages
425
Xender
X
S
  • Résolu(e)
Autres ActiveWorkbook.Worksheets("vierge").AutoFilter.Sort.SortFields.Clear
2
Réponses
23
Affichages
1 K
AtTheOne
AtTheOne
F
  • Résolu(e)
Microsoft 365 Message Box oui/non
Réponses
2
Affichages
124
Francky79
F

Membres actuellement en ligne

21 membres et 368 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 308
Messages
2 087 105
Membres
103 469
dernier inscrit
Thibz