Problème d'extraction entre 2 dates

Version imprimable

1 pièce(s) jointe(s)

Bonjour,
J'ai trouvé ce code sur un forum, mais après modification l'extraction entre 2 dates ne fonctionne plus avez vous une idée du souci

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
  Sub Extraction()
 
    ' Extraction entre deux dates
    ' Critères de dates     - Feuil1
    ' Base de données       - Feuil2
    ' Extraction            - Feuil3
 
    Sheets("Feuil3").Range("A1").CurrentRegion.Clear
 
      With Sheets("Feuil2")
        Application.CutCopyMode = False
 
       .Range("k2") = "=AND(a2>=Feuil1!A3,a2<=Feuil1!B3)"              'critères
        .Range("A1:g" & .Cells(Rows.Count, 7).End(xlUp).Row) _
        .AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
        .Range("E1:E7"), CopyToRange:=Sheets("Feuil3").Range("a1:g1"), Unique:=False
        .Range("k2") = ""
        '.Rows(1).Delete
      End With
    End Sub

19/05/2014, 11h10
vanhoa

Bonjour,

Tu souhaites faire quoi exactement?

Car de mon cote, sans rentrer dans le detail de ton code, je n'ai pas d'erreur de code qui intervient.
Tu as un message d'erreur?

Qu'est ce qui ne marche pas?

vanhoa
19/05/2014, 13h54
anelinette

Bonjour,
j'aimerai extraire les 7 colonnes de la feuil2 selon les dates de la feuil1 et avoir le résultat sur la feuil3

Mon souci c'est que je n'ai pas le bon tri par rapport à ma date de sélection :? si je sélectionne la date du 29 avril 2014, il me donne les valeurs du 29 et d'autre qui non rien à voir

(voir le fichier joint)

ok,

voici un code qui marche et qui t'evite de rentrer tes formules en dur:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Option Explicit
 
Sub Extraction()
Dim nblignes As Long, i As Long, lignedest As Long, j As Byte
 
Sheets("Feuil3").Range("A1").CurrentRegion.Clear
 
With Sheets("Feuil2")
    nblignes = .Cells(1, 1).End(xlDown).Row
    lignedest = 1
    For i = 1 To nblignes
        If .Cells(i, 1) >= Sheets("Feuil1").Cells(3, 1) And .Cells(i, 1) <= Sheets("Feuil1").Cells(3, 2) Then
            For j = 1 To 7
                Sheets("Feuil3").Cells(lignedest, j) = .Cells(i, j)
            Next j
            lignedest = lignedest + 1
        Else
        End If
    Next i
End With
 
End Sub

copie d'abord le format de ta Feuil2 dans ta Feuil3

dis moi si ca marche de ton cote

vanhoa

1 pièce(s) jointe(s)

Super ça fonctionne très bien
mais mon souci maintenant comme je ne comprends pas tout au vba, serait d'extraire de l'onglet "mouvement" a partir de la cellule b7, la même chose et mettre le résultat en feuil3

j'ai essayé, mais je n'y arrive pas

j'espère ne pas trop abuser de ta générosité :lol:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Sub Extraction1()
Dim nblignes As Long, i As Long, lignedest As Long, j As Byte
 
Sheets("feuil3").Range("A1").CurrentRegion.Clear
 
With Sheets("mouvements")
    nblignes = .Cells(1, 1).End(xlDown).Row
    lignedest = 1
    For i = 1 To nblignes
        If .Cells(i, 1) >= Sheets("Feuil1").Cells(3, 1) And .Cells(i, 1) <= Sheets("Feuil1").Cells(3, 2) Then
            For j = 1 To 7
                Sheets("feuil3").Cells(lignedest, j) = .Cells(i, j)
            Next j
            lignedest = lignedest + 1
        Else
        End If
    Next i
End With
 
End Sub

j'ai mis le fichier en pièce jointe

20/05/2014, 09h22
Marc-L

Bonjour, bonjour,

à mon avis l'idéal serait d'utiliser un filtre (exemple ici) ou encore un filtre avancé …

Voila le code qu'il te faut dans ce cas:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Sub Extraction1()
Dim nblignes As Long, i As Long, lignedest As Long, j As Byte
 
Sheets("feuil3").Range("A1").CurrentRegion.Clear
 
With Sheets("mouvements")
    nblignes = .Cells(6, 2).End(xlDown).Row
    lignedest = 1
    For i = 6 To nblignes
        If .Cells(i, 2) >= Sheets("Feuil1").Cells(3, 1) And .Cells(i, 2) <= Sheets("Feuil1").Cells(3, 2) Then
            For j = 2 To 8
                Sheets("feuil3").Cells(lignedest, j - 1) = .Cells(i, j)
            Next j
            lignedest = lignedest + 1
        Else
        End If
    Next i
End With
 
End Sub

comme ton onglet "mouvements" est different, tu dois adapter les lignes et colonnes.
J'ai teste le code, il fonctionne.

20/05/2014, 10h21
anelinette

Merci

super un grand merci !!!
ça fonctionne nickel !!
c'est exactement ce que je voulais

bonne journée
20/05/2014, 11h26
Menhir

Citation:

Envoyé par anelinette

ne fonctionne plus

C'est un peu limité comme description de problème...:roll:
Est-ce que ça a fonctionné "avant modification" ?
Qu'est-ce que ça devait faire ?
Quelles modifications ont été apportées ?
Qu'est que ça ne fait plus ?

Avec le plus de précisions possibles.