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