Discussion :

[silva-silva]

Bonjour à tous !
Après avoir éclusé le forum, je ne m'en sors toujours pas - et étant débutant et autodidacte, je sens bien qu'il me manque une info et j'aurais bien besoin de vos lumières d'experts.
Voici mon problème.

J'ai un tableau à cinq colonnes : Nom - Date - Montant - Référence - Dispatch

Dans ce tableau, les données sont classées par date puis, pour chaque date, par référence. Le nombre de lignes par date n'est pas fixe.
Je voudrais une macro qui lance une inputbox dans laquelle on rentrerait une date, puis qui sélectionnerait toutes les lignes correspondant à la date saisie et les copierait dans un feuillet à part.
Pour l'instant j'ai une macro, mais qui ne sélectionne / copie-colle que la dernière ligne à la date voulue, or j'aurais besoin qu'elle les sélectionne toutes...

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
Dim i As Integer
Dim nb_lig As Integer
Dim ds As Date
nb_lig = Range("A" & Rows.Count).End(xlUp).Row
ds = InputBox("Date souhaitée")
 
For i = 2 To nb_lig
    Set zone = Range("A" & i & ":E" & i)
    If Cells(i, 2) = ds Then Range("A" & i & ":E" & i).Copy
 
Next
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste
 
End Sub

Comment pourrais-je faire ?
Merci à tous

[Igloobel]

Bonjour à tous

je me suis permis d'ajouter quelques variables
je te propose une affectation de nb_lig un peu plus courte (que perso j'utilise très souvent) même si la tienne fonctionne très bien

voici donc une version de ton code qui fonctionne:

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
23
24
25
26
27
28
29
30
31
32
33
Sub test()
 
    Dim i As Integer
    Dim nb_lig As Integer
    Dim ds As Date
    Dim Der_Lign_Sel As Long
    Dim Deb_Lign_Sel As Long
 
 
'    nb_lig1 = Range("A" & Rows.Count).End(xlUp).Row
    nb_lig = [A1].End(xlDown).Row
 
    ds = InputBox("Date souhaitée")
    Deb_Lign_Sel = 0
 
    For i = 2 To nb_lig
        If Deb_Lign_Sel = 0 Then
            If Cells(i, 2).Value = ds Then
                Deb_Lign_Sel = i
            End If
        Else
            If Cells(i, 2).Value <> ds And Cells(i - 1, 2).Value = ds Then
                Der_Lign_Sel = i - 1
            End If
        End If
    Next
 
    Range(Cells(Deb_Lign_Sel, 1), Cells(Der_Lign_Sel, 5)).Copy
 
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
 
End Sub

il y a une gestion de ta feuille2 à faire
et moi pour une gestion plus simple de l'affaire je serais passé par un tableau en mémoire ou par un dictionnaire

si tu as besoin de plus d'explication n'hésites pas

A bientôt

[ARTURO83]

Bonjour,

Autre solution en passant par un filtre

Code :

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

1
2
3
4
5
6
7
8
9
    Dim i As Long, NbVal As Long, nb_lig As Long
    Dim ds As Date
    nb_lig = Range("A" & Rows.Count).End(xlUp).Row
    ds = InputBox("Date souhaitée")
    ActiveSheet.Range("A1:E" & nb_lig).AutoFilter Field:=2, Criteria1:=ds
    NbVal = Range("_FilterDataBase").Resize(, 1).SpecialCells(xlCellTypeVisible).Count - 1
    Range("_FilterDataBase").Resize(, 5).SpecialCells(xlCellTypeVisible).Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste

Cdlt

[silva-silva]

Bonjour à tous

je me suis permis d'ajouter quelques variables
je te propose une affectation de nb_lig un peu plus courte (que perso j'utilise très souvent) même si la tienne fonctionne très bien

voici donc une version de ton code qui fonctionne:

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
23
24
25
26
27
28
29
30
31
32
33
Sub test()
 
    Dim i As Integer
    Dim nb_lig As Integer
    Dim ds As Date
    Dim Der_Lign_Sel As Long
    Dim Deb_Lign_Sel As Long
 
 
'    nb_lig1 = Range("A" & Rows.Count).End(xlUp).Row
    nb_lig = [A1].End(xlDown).Row
 
    ds = InputBox("Date souhaitée")
    Deb_Lign_Sel = 0
 
    For i = 2 To nb_lig
        If Deb_Lign_Sel = 0 Then
            If Cells(i, 2).Value = ds Then
                Deb_Lign_Sel = i
            End If
        Else
            If Cells(i, 2).Value <> ds And Cells(i - 1, 2).Value = ds Then
                Der_Lign_Sel = i - 1
            End If
        End If
    Next
 
    Range(Cells(Deb_Lign_Sel, 1), Cells(Der_Lign_Sel, 5)).Copy
 
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
 
End Sub

il y a une gestion de ta feuille2 à faire
et moi pour une gestion plus simple de l'affaire je serais passé par un tableau en mémoire ou par un dictionnaire

si tu as besoin de plus d'explication n'hésites pas

A bientôt

Merveilleux, ça fonctionne nickel ! Trop, trop bien. Et au passage j'ai appris de nouvelles fonctions que je ne connaissais pas.

Merci à tous les deux et très bonne journée à vous !