Extraction tableau de date a date : Macro?

frusciantefan

XLDnaute Junior
Bonjour à tous!

Encore Novice en developpement VBA, je fais appel a vos compétences en macro pour une tâche que je souhaiterais automatiser.

Je voudrais faire une extraction de toutes les lignes de mon tableau (ligne de titre incluse) via une macro.

Je souhaiterai qu'une boite de dialogue apparaisse lorsque l'on clique sur le bouton "extraction" qui proposerait deux champs :

1- A partir de quelle date (JJ/MM/AAAA) souhaitez vous faire l'extraction?
2- Jusqu'a quelle date (JJ/MM/AAAA) souhaitez vous faire l'extraction?

==> Il irait chercher l'extraction des dates au niveau de la colonne I du fichier test.

Une fois remplis, je voudrais que la macro ouvre un nouveau fichier excel et aille copier les lignes de mon tableau (toujours avec la ligne de titre) correspondant à l'extraction demandée.

Pouvez vous m'aider a réaliser ce projet?

Merci à vous :)

FF
 

Pièces jointes

  • test macro.xls
    14.5 KB · Affichages: 63
  • test macro.xls
    14.5 KB · Affichages: 61
  • test macro.xls
    14.5 KB · Affichages: 66

Modeste

XLDnaute Barbatruc
Re : Extraction tableau de date a date : Macro?

Bonjour frusciantefan,

Il me semble que le plus simple serait d'utiliser un filtre élaboré ... et l'enregistreur de macro, pour générer le code de départ.
Vois ensuite si tu peux adapter ce code et reviens-nous avec une début de solution ... Il se trouvera bien quelqu'un pour t'aider à poursuivre!
 

Gael

XLDnaute Barbatruc
Re : Extraction tableau de date a date : Macro?

Bonjour FF, Modeste,

Question subsidiaire: les dates en colonne I sont-elles toujours en ordre croissant ?

Gael

Question stupide, désolé j'avais mal regardé l'exemple.
 

job75

XLDnaute Barbatruc
Re : Extraction tableau de date a date : Macro?

Bonjour frusciantefan , salut Modeste, Gael :)

Voici une solution :

Code:
Sub Extraction()
Dim F As Worksheet, rep$, dat1 As Date, dat2 As Date, cel As Range, plage As Range
Set F = Sheets("Feuil1") 'à adapter
If ActiveSheet.Name <> F.Name Then Exit Sub
On Error Resume Next
1 rep = InputBox("Date de départ et date de fin séparées par un tiret" _
  & Chr(10) & Chr(10) & "Format jjj/mm/aa-jj/mm/aa :", "Extraction")
If rep = "" Then Exit Sub
Err = 0
dat1 = Split(rep, "-")(0)
dat2 = Split(rep, "-")(1)
If Err Then GoTo 1
Set plage = [A3:H3]
For Each cel In Range("I4", [I65536].End(xlUp))
If cel >= dat1 And cel <= dat2 Then Set plage = Union(Cells(cel.Row, 1).Resize(, 8), plage)
Next
Application.ScreenUpdating = False
Workbooks.Add
F.Cells.Copy Cells 'pour la dimension des colonnes
Cells.Clear
plage.Copy [A1]
'enregistrez le document si vous voulez
End Sub
Si le tableau est très grand, on peut gagner du temps d'exécution en utilisant une variable tableau.

Dites-nous seulement quel est le temps d'exécution sur votre fichier réel.

A+
 

Pièces jointes

  • Extraction(1).xls
    36.5 KB · Affichages: 73
  • Extraction(1).xls
    36.5 KB · Affichages: 75
  • Extraction(1).xls
    36.5 KB · Affichages: 87

frusciantefan

XLDnaute Junior
Re : Extraction tableau de date a date : Macro?

Pas toujours, mais en fait, je rectifie, la colonne I n'est pas a prendre en compte, on ne fait l'extraction que sur la date d'enregistrement, soit la colonne A !

Modeste,

Je voulais justement eviter le filtre élaboré. J'ai tout de même tenter :

Range("A3:H3").Select
Selection.AutoFilter
Selection.AutoFilter Field:=1, Criteria1:=">01/03/2011", Operator:=xlAnd _
, Criteria2:="<18/03/2011" ==> Je voudrais que ces champs la soient présentés a travers un msgbox.
End Sub


Une fois filtrer, je peux avoir 1 ligne comme je peux en avoir 30, du coup, il faudrait un code qui me permettre de copier le nombre exact de lignes extraites mais la je sèche totalement... :(
 

frusciantefan

XLDnaute Junior
Re : Extraction tableau de date a date : Macro?

C'est Génial exactement ce que je cherchais !!
En revanche lorsque je place mon bouton d'execution de macro dans ma feuille, il me le recopie aussi, alors que dans l'exemple non...
Je ne comprend pas ou est l'erreur?

Un grand merci en tous cas!

FF
 

Modeste

XLDnaute Barbatruc
Re : Extraction tableau de date a date : Macro?

Re-bonjour, salut Gaël (il y avait longtemps!)

@frusciantefan: Le code de job vaut certainement le détour et devrait répondre à tes attentes.
En ce qui me concerne, j'avais en tête les filtres élaborés, pas automatiques! L'étape suivante aurait permis d'afficher une boîte de dialogue, pour saisir les dates (elles sont ici, dans la feuille2)

Edit: je suis encore en retard!
 

Pièces jointes

  • Filtre élaboré (frusciantefan).xls
    27 KB · Affichages: 59

job75

XLDnaute Barbatruc
Re : Extraction tableau de date a date : Macro?

Re,

Pour ne pas copier votre bouton, lui donner la propriété "Ne pas déplacer ou dimensionner avec les cellules".

Par ailleurs Modeste a tout à fait raison.

La meilleur solution (la plus rapide) est sans doute celle du Filtre automatique :

Code:
Sub Extraction()
Dim F As Worksheet, rep$, dat1#, dat2#, plage As Range
Set F = Sheets("Feuil1") 'à adapter
If ActiveSheet.Name <> F.Name Then Exit Sub
On Error Resume Next
1 rep = InputBox("Date de départ et date de fin séparées par un tiret" _
  & Chr(10) & Chr(10) & "Format jjj/mm/aa-jj/mm/aa :", "Extraction")
If rep = "" Then Exit Sub
Err = 0
dat1 = CDbl(CDate(Split(rep, "-")(0)))
dat2 = CDbl(CDate(Split(rep, "-")(1)))
If Err Then GoTo 1
Application.ScreenUpdating = False
F.AutoFilterMode = False
Set plage = Range("A3", [I65536].End(xlUp))
plage.AutoFilter 9, ">=" & dat1, xlAnd, "<=" & dat2
Set plage = plage.SpecialCells(xlCellTypeVisible)
F.AutoFilterMode = False
Workbooks.Add
F.Cells.Copy Cells 'pour la dimension des colonnes
Cells.Clear
plage.Copy [A1]
[I:I].Clear
'enregistrez le document si vous voulez
End Sub
Fichier (2).

A+
 

Pièces jointes

  • Extraction(2).xls
    37 KB · Affichages: 75
  • Extraction(2).xls
    37 KB · Affichages: 88
  • Extraction(2).xls
    37 KB · Affichages: 85

Discussions similaires

Réponses
2
Affichages
276

Statistiques des forums

Discussions
312 413
Messages
2 088 199
Membres
103 760
dernier inscrit
antar gass