Macro pour extraire certaines cellules sur un autre fichier

D

donssalus

XLDnaute Nouveau
Bonjour à tous ,

je souhaite connaître la macro qui me permettrais d'extraire et d'exporter certaines cellules vers un autre fichier.
En effet, ce fichier comportera plusieurs élèves avec leurs résultats. Et je ne souhaite exporter automatiquement que les échecs de l'élève sur un fichier à part.
Ex si l'élève est en échec en math et en géo et bien apparaîtront que ces 2 résultats là dans un autre fichier.
Cela permettra de gagner du temps, que de cibler les échecs et les noter à la main sur une feuille part.

merci d'avance pour les réponses que j'obtiendrai. :)
 

Pièces jointes

  • extract.xlsx
    8.8 KB · Affichages: 39
  • extract.xlsx
    8.8 KB · Affichages: 39
  • extract.xlsx
    8.8 KB · Affichages: 46
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Re : Macro pour extraire certaines cellules sur un autre fichier

Re

J'ai supposé que les notes sont éditées mensuellement, alors j'ai nommé le fichier source avec 2014-01 (janvier).

Cette macro traite la feuille active et se lance par les touches Ctrl+E :

Code: 
Sub ExporterEchecs()
'se lance par Ctrl+E
Dim chemin$, P As Range, n&, c As Range, nom$
chemin = ThisWorkbook.Path & "\" 'à adapter éventuellement
Set P = ActiveSheet.UsedRange
If Application.CountIf(P.Columns(2), "<10") = 0 Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
With Workbooks.Add(xlWBATWorksheet).Sheets(1) 'nouveau document
  .Name = P.Parent.Name
  P(1).Resize(2, 2).Copy .[A1]
  n = 2
  For Each c In P.Columns(2).Cells
    If c < 10 And c <> "" Then
      n = n + 1
      .Cells(n, 2) = c
      .Cells(n, 1) = c(1, 0)
    End If
  Next
  nom = Left(Split(ThisWorkbook.Name)(1), 7) 'année-mois
  nom = .[B1] & " " & .[A1] & " " & nom
  Workbooks(nom).Close ' au cas où ce fichier serait ouvert
  ActiveWorkbook.SaveAs chemin & nom
  ActiveWorkbook.Close
End With
End Sub
Fichier joint, à télécharger sur le disque dur pour tester.

A+
 

Pièces jointes

  • Notes 2014-01.xlsm
    18.1 KB · Affichages: 35
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Macro pour extraire certaines cellules sur un autre fichier

Re,

On peut aussi traiter toutes les feuilles à la fermeture du fichier.

Dans ThisWorkbook :

Code: 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim w As Worksheet
Me.Save
For Each w In Worksheets
  ExporterEchecs w
Next
End Sub
La macro ExporterEchecs est alors paramétrée.

Fichier 02 joint.

A+
 

Pièces jointes

  • Notes 2014-02.xlsm
    18.2 KB · Affichages: 32
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Macro pour extraire certaines cellules sur un autre fichier

Bonjour donssalus, le forum,

Quelques améliorations :

- un dossier Echecs est créé pour accueillir les fichiers

- la base de notation en B2 (/20) est utilisée

- la largeur de la colonne A est ajustée automatiquement.

Code: 
Sub ExporterEchecs(w As Worksheet)
Dim chemin$, P As Range, note, n&, c As Range, nom$
chemin = ThisWorkbook.Path & "\Echecs\" 'à adapter éventuellement
Set P = w.UsedRange
If InStr(P(2, 2), "/") = 0 Then Exit Sub
note = Split(P(2, 2), "/")(1) / 2 'note limite
If Application.CountIf(P.Columns(2), "<" & note) = 0 Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
MkDir chemin 'crée le dossier Echecs s'il n'existe pas
With Workbooks.Add(xlWBATWorksheet).Sheets(1) 'nouveau document
  .Name = P.Parent.Name
  P(1).Resize(2, 2).Copy .[A1]
  n = 2
  For Each c In P.Columns(2).Cells
    If c < note And c <> "" Then
      n = n + 1
      .Cells(n, 2) = c
      .Cells(n, 1) = c(1, 0)
    End If
  Next
  .Columns(1).AutoFit 'ajustement automatique
  nom = Left(Split(ThisWorkbook.Name)(1), 7) 'année-mois
  nom = .[B1] & " " & .[A1] & " " & nom
  Workbooks(nom).Close ' au cas où ce fichier serait ouvert
  ActiveWorkbook.SaveAs chemin & nom
  ActiveWorkbook.Close
End With
End Sub
Fichier 03 joint.

A+
 

Pièces jointes

  • Notes 2014-03.xlsm
    19.9 KB · Affichages: 42
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Macro pour extraire certaines cellules sur un autre fichier

Re,

Ah mais voilà qui est fort intéressant.

En utilisant SaveCopyAs la création de 100 fichiers s'effectue en 5,8 secondes :

Code: 
Sub ExporterEchecs(w As Worksheet)
Dim chemin$, P As Range, note, n&, c As Range, nom$
chemin = ThisWorkbook.Path & "\Echecs\" 'à adapter éventuellement
Set P = w.UsedRange
If InStr(P(2, 2), "/") = 0 Then Exit Sub
note = Split(P(2, 2), "/")(1) / 2 'note limite
If Application.CountIf(P.Columns(2), "<" & note) = 0 Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
MkDir chemin 'crée le dossier Echecs s'il n'existe pas
With Workbooks.Add(xlWBATWorksheet).Sheets(1) 'nouveau document
  .Name = P.Parent.Name
  P(1).Resize(2, 2).Copy .[A1]
  n = 2
  For Each c In P.Columns(2).Cells
    If c < note And c <> "" Then
      n = n + 1
      .Cells(n, 2) = c
      .Cells(n, 1) = c(1, 0)
    End If
  Next
  .Columns(1).AutoFit 'ajustement automatique
  nom = Left(Split(ThisWorkbook.Name)(1), 7) 'année-mois
  nom = .[B1] & " " & .[A1] & " " & nom & _
    IIf(Val(Application.Version) < 12, ".xls", ".xlsx")
  Workbooks(nom).Close ' au cas où ce fichier serait ouvert
  ActiveWorkbook.SaveCopyAs chemin & nom
  ActiveWorkbook.Close
End With
End Sub
Je n'avais jamais comparé SaveAs et SaveCopyAs :rolleyes:

Fichier 04.

Edit : j'ai ajouté un test pour que la macro fonctionne sur les versions antérieures à Excel 2007.

A+
 

Pièces jointes

  • Notes 2014-04.xlsm
    20.2 KB · Affichages: 43
Dernière édition:
Vote positif 0 Vote négatif
D

donssalus

XLDnaute Nouveau
Re : Macro pour extraire certaines cellules sur un autre fichier

merci à tous pour vos messages.
j'ai l'embarras du choix.
Mais est-il possible justement de récupérer les échecs que sur un fichier avec les onglets des élèves apparaissant comme sur le fichier de base.
Car nous travaillons par classe. Et donc il est plus facile de centraliser uniquement les échecs par classe.

merci d'avance
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Macro pour extraire certaines cellules sur un autre fichier

Re,

Voici la macro si l'on veut un seul fichier :

Code: 
Sub ExporterEchecs()
Dim chemin$, i%, P As Range, note, nom$
chemin = ThisWorkbook.Path & "\" 'à adapter éventuellement
ThisWorkbook.Save 'enregistrement normal
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
For i = Worksheets.Count To 1 Step -1
  Set P = Worksheets(i).UsedRange
  If InStr(P(2, 2), "/") = 0 Then Worksheets(i).Delete: GoTo 1
  note = Split(P(2, 2), "/")(1) / 2 'note limite
  If Application.CountIf(P.Columns(2), "<" & note) = 0 _
    Then Worksheets(i).Delete: GoTo 1
  P.Offset(1).AutoFilter 2, ">=" & note 'filtre automatique
  P.Offset(2).SpecialCells(xlCellTypeVisible).EntireRow.Delete
  P.Parent.AutoFilterMode = False
  P.Columns(3).Resize(, P.Columns.Count).Delete xlToLeft
  P.Columns(1).AutoFit 'ajustement automatique
1 Next
nom = ThisWorkbook.Name
nom = "Echec " & Left(nom, InStrRev(nom, ".") - 1)
Workbooks(nom).Close 'au cas où ce fichier serait ouvert
ThisWorkbook.SaveAs chemin & nom, 51 'format .xlsx
End Sub
La macro utilise le filtre automatique sur chaque feuille comportant des échecs.

Avec 100 onglets la durée d'exécution est de 2,5 secondes.

Le fichier joint porte un nom de classe.

Edit : curieux, je n'avais pas joint le bon fichier :confused:

A+
 

Pièces jointes

  • 6ème-1.xlsm
    19.4 KB · Affichages: 33
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Macro pour extraire certaines cellules sur un autre fichier

Bonjour donssalus, le forum,

Sur cette version 2 les feuilles autres que des feuilles de calcul sont supprimées.

A+
 

Pièces jointes

  • 6ème-2.xlsm
    23.1 KB · Affichages: 37
Vote positif 0 Vote négatif
D

donssalus

XLDnaute Nouveau
Re : Macro pour extraire certaines cellules sur un autre fichier

merci pour le fichier.

actuellement le fichier ne prend pas en considération les échecs, est-ce normal ? à la fermeture il me crée bien les onglets mais les échecs n'apparaissent pas .
Serait-il possible d'y venir y mettre d'autres critères d'éechecs. Par ex quand la cote est sur /2° forcement l'échec comment à 9 ais quand la cotation de la période sera sur /40 l'échec commence à 19.

merci
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Macro pour extraire certaines cellules sur un autre fichier

Re,

Je ne comprends pas, les fichiers de mes posts #10 et #11 fonctionnent correctement chez moi.

Joignez votre fichier qui ne fonctionne pas.

Quant aux notes sur 40 je vois que vous n'avez pas du tout compris l'utilité de la variable note !!!

A+
 
Vote positif 0 Vote négatif

Discussions similaires

chris6999
  • Question
Microsoft 365 MACRO VBA - Extraire des listes à partir d'une boucle
Réponses
5
Affichages
254
chris6999
chris6999
N
  • Question
Microsoft 365 Mise à jour de données d'un fichier Excel à un autre, sous Sharepoint
Réponses
0
Affichages
149
Newbeee
N
F
  • Question
XL 2019 Extraire des lignes suivant somme des colonnes pour alimenter un autre tableau
Réponses
1
Affichages
254
fanfan38
fanfan38
P
  • Question
XL 2019 Copier des cellules d'une feuille sur une autre
Réponses
2
Affichages
276
phoceenjo
P
J
  • Résolu(e)
Microsoft 365 Copie cellules dans un autre onglet
Réponses
4
Affichages
279
julien1982
J
H
  • Résolu(e)
XL 2019 récupérer une donnée d'un fichier csv pour le copier vers un autre
2
Réponses
27
Affichages
1 K
Hutchy33
H
L
  • Question
XL 2013 Macro pour exporter sur excel certaines données d'un fichier txt
Réponses
1
Affichages
436
sylvanu
sylvanu
D
  • Résolu(e)
Microsoft 365 Copies de certaines cellules vers une autre feuille Excel
Réponses
7
Affichages
561
duclorenzo
D
Usine à gaz
  • Question
XL 2021 formule pour modifier le CONTENU de certaines cellules
2
Réponses
23
Affichages
1 K
Usine à gaz
Usine à gaz
M
  • Question
Microsoft 365 Travailler sur un fichier EXCEL avec une date volontairement incorrecte
Réponses
3
Affichages
333
Dudu2
Dudu2

Membres actuellement en ligne

16 membres et 172 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 492
Messages
2 088 914
Membres
103 983
dernier inscrit
AlbertCouillard