extraire ligne ou cellule est comprise entre deux dates [Résolu]

[tiktak28]

bonjour les amis j'ai un peu parcouru le forum en long en large et en travers mais j'ai pas trouver mon bonheur.

en fait je souhaiterai extraire les lignes de mon tableau de données vers un autre classeur lorsque la cellule de la colone g est comprise entre la date d'aujourd'hui+27jours et aujourdhui+35jours et ce sur simple clic d'un bouton.
la je galère avec mes filtres chaque semaine ça me saoule.
merci à ceux qui m'aideront

[Pierre Fauconnier]

Salut.

Voici une première approche, à peaufiner. Il faut que la plage (a1:a6 dans le code proposé) soit pourvue du filtre automatique.

C'est donc plus une approche de la démarche qu'un code fonctionnel "clé sur porte".

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Sub Test()
  Dim Plage As Range
  Dim Classeur As Workbook
  Dim Feuille As Worksheet
 
  Set Feuille = ActiveSheet
  Set Classeur = Workbooks.Add()
  ThisWorkbook.Activate
  Feuille.Activate
  Set Plage = Range("a1:a13")
  Plage.AutoFilter field:=1, Criteria1:=">=" & Date * 1 + 27, Operator:=xlAnd, Criteria2:="<=" & Date * 1 + 35
  Plage.SpecialCells(xlCellTypeVisible).Copy Destination:=Classeur.Worksheets(1).Range("a1")
 
End Sub

On peut envisager une approche plus itérative (moins Excel et plus VBA)

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sub Test1()
  ' approche itérative
 
  Dim Cellule As Range
  Dim BorneInferieure As Date, BorneSuperieure As Date
  Dim Classeur As Workbook
  Dim CelluleCible As Range
  Dim Feuille As Worksheet
 
  BorneInferieure = Date + 27
  BorneSuperieure = Date + 35
 
  Set Feuille = ActiveSheet
  Set Classeur = Workbooks.Add()
  Set CelluleCible = Classeur.Worksheets(1).Range("a1")
  Feuille.Activate
  For Each Cellule In Feuil3.Range("a2:a" & Feuil3.Cells(Feuil3.Rows.Count, 1).End(xlUp).Row)
    If Cellule.Value >= BorneInferieure And Cellule.Value <= BorneSuperieure Then
      Cellule.EntireRow.Copy Destination:=CelluleCible
      Set CelluleCible = CelluleCible(2)
    End If
  Next Cellule
End Sub

[tiktak28]

merci pour cette réponse rapide et ô combien pertinente. Malheureusement je n'arrive qu'à obtenir des classeurs vides j'ai bidouillé un peu tout mais rien à faire.est ce qu'il serait possible pour vous de m'aider un peu plus encore par exemple je peux héberger le fichier pour que vous y jetiez un oeil?

[Pierre Fauconnier]

Et si tu mettais ton code avec les messages éventuels d'erreur?

[tiktak28]

Bonsoir, bon c'est plus agréable d'écrire sur pc que sur mon téléphone portable

Alors!

Voilà ce que j'ai mis

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Sub Bouton1_QuandClic()
 
Dim Cellule As Range
Dim BorneInferieure As Date, BorneSuperieure As Date
Dim Classeur As Workbook
Dim Feuille As Worksheet
Dim CelluleCible As Range
BorneSuperieure = Date + 35
BorneInferieure = Date + 27
 
Set Feuille = ActiveSheet
Set Classeur = Workbooks.Add()
Set CelluleCible = Classeur.Worksheets(1).Range("a1")
Feuille.Activate
For Each Cellule In Feuille.Range("a2:a" & Feuille.Cells(Feuille.Rows.Count, 7).End(xlUp).Row)
        If Cellule.Value >= BorneInferieure And Cellule.Value <= BorneSuperieure Then
    Cellule.EntireRow.Copy Destination:=CelluleCible
    Set CelluleCible = CelluleCible(2)
        End If
Next Cellule
End
 
 
End Sub

J'ai juste changé cette ligne là

Code :

For Each Cellule In Feuille.Range("a2:a" & Feuille.Cells(Feuille.Rows.Count, 7).End(xlUp).Row)

Ca me crée bien une feuille mais elle est vierge.

[mercatog]

Ci-joint proposition complète commentée (proposée par Pierre Fauconnier) utilisant un filtre automatique et sans rien activer.
L'extraction est établie dans un nouveau classeur sauvegardé dans le même répertoire.

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Sub Test()
Dim Classeur As Workbook
Dim LastLig As Long
 
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Feuil7")  '!!!! à adapter au nom de ta feuille
    'On enlève l'éventuel filtre automatique
    .AutoFilterMode = False
    'N° de ligne de la dernière cellule remplie de la colonne A
    LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
    If LastLig > 1 Then
        'On ajoute un nouveau classeur avec une seule feuille
        Set Classeur = Workbooks.Add(1)
        With .Range("A1:X" & LastLig)
            'On filtre la colonne A entre les 2 dates
            .AutoFilter Field:=1, Criteria1:=">=" & CLng(Date) + 27, Operator:=xlAnd, Criteria2:="<=" & CLng(Date) + 35
            'On copie les colonnes A à X visibles vers le classeur qu'on vient de créer
            .SpecialCells(xlCellTypeVisible).Copy Classeur.Worksheets(1).Range("A1")
        End With
        'On enlève le filtre automatique
        .AutoFilterMode = False
    End If
End With
'On sauvegarde notre classeur et on le ferme
Classeur.SaveAs ThisWorkbook.Path & "\Extract_" & Format(Now, "ddmmyyyyhhnns"), xlNormal
Classeur.Close
Set Classeur = Nothing
End Sub

[tiktak28]

Merci beaucoup mercatog, ça fonctionne quasiment à la perfection.
Je vais juste intervertir ma colonne G et ma colonne A pour me faciliter la vie

[mercatog]

Si tes dates sont en colonne G, il suffit juste de mettre 7 à l place 1 dans le paramètre Field de l'autofilter (Ligne 16)

Code :

            .AutoFilter Field:=7, Criteria1:=">=" & CLng(Date) + 27, Operator:=xlAnd, Criteria2:="<=" & CLng(Date) + 35

[tiktak28]

Merci l'ami, maintenant je vais essayer d'automatiser la mise en forme, j'espère que je pourrai compter sur vous en cas de coup dur ^^