Discussion :

[anelinette]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[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

[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)

[vanhoa]

ok,

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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[anelinette]

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é

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[Marc-L]

Bonjour, bonjour,

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

[vanhoa]

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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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.

[anelinette]

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

bonne journée

[Menhir]

ne fonctionne plus

C'est un peu limité comme description de problème...
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.