macro pour extraire des données avec condition

[satfilter]

Bonjour,
je génére un fichier excel (piece jointe) tous les jours et je souhaiterai avoir une macro qui agisse sur celui ci et extrait les lignes qui remplissent la condition suivante dans un autre fichier :
AS x 0.75 soit inferieur ou égal a BE.

En gros, je voudrai un fichier indépendant qui va chercher les infos dans un autre et en génére un troisième.
Merci pour votre aide.
A+

 

[Compte Supprimé 979]

Re : macro pour extraire des données avec condition

Salut Satfilter

Voici un exemple de ce que l'on peut faire pour ce que tu souhaites

Par défaut le fichier "base.xls" sera ouvert dans le répertoire de la macro
mais tu peux modifier cela dans le code

A+

 

[job75]

Re : macro pour extraire des données avec condition

Bonjour satfilter,

Vous pouvez exécuter cette macro :

Sub NouveauFichier()
Dim col%, chemin$, fichier$
Application.ScreenUpdating = False
'---nouveau document---
Workbooks("base.xls").Sheets("Sheet1").Copy
With ActiveWorkbook.Sheets(1).UsedRange
  col = .Columns.Count + 1
  .Columns(col).FormulaR1C1 = "=LN(RC45*0.75<=RC57)"
  .Columns(col) = .Columns(col).Value
  .Resize(, col).Sort .Columns(col), xlAscending, Header:=xlYes
  On Error Resume Next
  .Columns(col).Offset(1).SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete
  .Columns(col).ClearContents
End With
'---enregistrement---
chemin = ThisWorkbook.Path & "\" 'à adapter
fichier = "Mon beau fichier " & Format(Now, "dd-mm-yyyy") 'à adapter
ActiveWorkbook.SaveAs chemin & fichier
ActiveWorkbook.Close False 'facultatif
End Sub

Remarques :

- le fichier contenant la macro doit avoir été enregistré

- le fichier base.xls doit être ouvert

- sur Excel 2007 et versions suivantes le nouveau fichier sera enregistré en .xlsx.

Edit : salut Bruno

A+

 

[satfilter]

Re : macro pour extraire des données avec condition

Bonjour
merci pour vos réponses, je suis plus au travail je testerai ça lundi, mais ça a l'air bien cohérent, pas incompréhensible, nickel.
Sinon, on est obligé d'avoir le fichier ouvert ?
Merci
A+

 

[job75]

Re : macro pour extraire des données avec condition

Re,

Sinon, on est obligé d'avoir le fichier ouvert ?

C'est plus simple mais pas obligé.

S'il n'est pas ouvert il faut l'ouvrir avec Workbooks.Open + le chemin d'accès.

A+

 

[satfilter]

Re : macro pour extraire des données avec condition

Re,



C'est plus simple mais pas obligé.

S'il n'est pas ouvert il faut l'ouvrir avec Workbooks.Open + le chemin d'accès.

A+

Ok, je suis sur mac et il semble qu'il y ai un léger bug au niveau du chemin, mais ien de grave je pense (sous win au boulot)
Merci beaucoup
A+

 

[job75]

Re : macro pour extraire des données avec condition

Bonjour satfilter, Bruno, le forum,

Si les fichiers sont dans le même dossier (même chemin d'accès) :

Sub NouveauFichier()
Dim chemin$, source$, nom$, col%, nouveau$
chemin = ThisWorkbook.Path & "\" 'à adapter
source = "base.xls"
nom = ActiveWorkbook.Name
Application.ScreenUpdating = False
On Error Resume Next
Workbooks.Open chemin & source 'ouverture du fichier source
'---nouveau document---
Workbooks(source).Sheets(1).Copy
If ActiveWorkbook.Name = nom Then _
  MsgBox "Fichier '" & source & "' introuvable !": Exit Sub
With ActiveWorkbook.Sheets(1).UsedRange
  col = .Columns.Count + 1
  .Columns(col).FormulaR1C1 = "=LN(RC45*0.75<=RC57)"
  .Columns(col) = .Columns(col).Value
  .Resize(, col).Sort .Columns(col), xlAscending, Header:=xlYes
  .Columns(col).Offset(1).SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete
  .Columns(col).ClearContents
End With
'---enregistrement---
nouveau = "Mon beau fichier " & Format(Now, "dd-mm-yyyy") 'à adapter
ActiveWorkbook.SaveAs chemin & nouveau
ActiveWorkbook.Close False 'facultatif
Workbooks(source).Close 'facultatif
End Sub

La macro ouvre donc le fichier source base.xls.

Edit : comme le fichier source n'a qu'une feuille il vaut mieux écrire :

Workbooks(source).Sheets(1).Copy

Ainsi le nom de la feuille n'a pas d'importance.

A+

 

[satfilter]

Re : macro pour extraire des données avec condition

Bonjour,
voila le code que j'ai actuellement :

Sub RécupDonnées()
  Dim sPath As String, sFic As String
  Dim ShtD As Worksheet
  Dim DLig As Long, Lig As Long, NLig As Long
  '
  ' Définir le chemin d'accés au fichier
  sPath = ThisWorkbook.Path & "\"
  '
  ' Définir le nom du fichier à ouvrir
  sFic = "base.xls"
  ' Définir la feuille de destination des données
  Set ShtD = ThisWorkbook.Worksheets("Données")
  ShtD.Cells.ClearContents
  '
  ' Ouvrir le fichier
  Workbooks.Open sPath & sFic
  ' Trouver la dernière ligne de la feuille
  With ActiveWorkbook.Sheets(1)
    ' Trouver le numéro de la dernière ligne remplie
    DLig = .Range("A" & Rows.Count).End(xlUp).Row
    ' Pour chaque ligne
    For Lig = 2 To DLig
      ' AS x 0.75 soit inferieur ou égal a BE.
      If .Range("AS" & Lig).Value * 0.8 <= .Range("BE" & Lig).Value Then
        ' Trouver la prochaine ligne vide de la feuille de destination
        NLig = ShtD.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
        ' Copier / coller la ligne correspondant au critére
        .Rows(&O1).Copy Destination:=ShtD.Rows(&O1)
        .Rows(Lig).Copy Destination:=ShtD.Rows(NLig)
      End If
    Next Lig
  End With
  ' Fermer le classeur à la fin
  ActiveWorkbook.Close SaveChanges:=xlNo
  ' Enregistrer la feuille données dans un autre classeur
  ShtD.Copy After:=Workbooks("***\EtatBudget\ComptesDanger.xlsx").Sheets(1)
  
  'With ActiveWorkbook
    '.SaveAs "***\EtatBudget\ComptesDanger.xlsx"
    '.Close SaveChanges:=xlNo
    'End With
    'ActiveWorkbook.Close SaveChanges:=xlNo
    'Application.Quit
  ' Petit message
' MsgBox "C'est fini"
End Sub

Donc, nous allons bien chercher dans base.xls les données a récupérer.
Ensuite enregistrement dans ShtD des résultats.
En fait, je voudrai que Shtd se copie dans ComptesDanger.xlsx en feuille 1 mais sans écraser le classeur complet car je veux avoir un croisé dynamique en feuille 2 de ce classeur.
J'ai un bug au niveau de :

ShtD.Copy After:=Workbooks("***\EtatBudget\ComptesDanger.xlsx").Sheets(1)

Merci pour votre aide.
A+

 

[satfilter]

Re : macro pour extraire des données avec condition

Bon,
ça a l'air bon avec

Workbooks.Open dFic

Application.DisplayAlerts = False
Sheets("Données").Delete
Application.DisplayAlerts = True

ShtD.Copy Before:=ActiveWorkbook.Sheets(1)
ActiveWorkbook.Close SaveChanges:=xlNo

Ou dFic est le chemin du fichier de destination
Merci pour tout
a+