Besoin Usf qui permet recherche selon intervalle de date

**duplaly** · 09/03/2011, 20h04

Salut les experts

Voici ma situation.
Sur le fichier joint j'aimerais créer un usf qui va me permettre de faire des recherches: selon une intervalle de date (saisir date début et date fin) colonne A
et un mot de colonne J.

et de m'afficher les résultats (copie ligne entière) sur une nouvelle feuille qui aura le nom du mot recherché.

Je suis bloqué à ce niveau et j'espere un coup de main de votre part.

Merci d'avance.

**mercatog** · 09/03/2011, 20h27

Bonjour
TextBox1: Date début
TextBox2: Date fin
TextBox3: Mot en colonne J à chercher

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
Private Sub Recherche_Click()
Dim Derlg As Long, DD As Long, DF As Long
Dim Sh As Worksheet
 
Application.ScreenUpdating = False
With Sheets("Empl")
    .AutoFilterMode = False
    Derlg = .Range("A" & .Rows.Count).End(xlUp).Row
    If IsDate(Me.TextBox1.Value) And IsDate(Me.TextBox2.Value) And Me.TextBox3.Value <> "" Then
        DD = CLng(DateValue(Me.TextBox1.Text))
        DF = CLng(DateValue(Me.TextBox2.Text))
        .Range("A1:J" & Derlg).AutoFilter field:=1, Criteria1:=">=" & DD, Criteria2:="<=" & DF, Operator:=xlAnd
        .Range("A1:J" & Derlg).AutoFilter field:=10, Criteria1:=Me.TextBox3.Text
        If .Range("A1:A" & Derlg).SpecialCells(xlCellTypeVisible).Count > 1 Then
            On Error Resume Next
            Set Sh = Sheets(Me.TextBox3.Text)
            On Error GoTo 0
            If Sh Is Nothing Then
                Set Sh = Worksheets.Add(After:=Worksheets(1))
                Sh.Name = Me.TextBox3.Text
                .Rows(1).Copy Sh.Range("A1")
            End If
            .Range("A2:J" & Derlg).SpecialCells(xlCellTypeVisible).Copy Sh.Cells(Sh.Rows.Count, 1).End(xlUp)(2)
            Set Sh = Nothing
        End If
    End If
    .AutoFilterMode = False
End With
Unload Me
End Sub

**duplaly** · 09/03/2011, 22h27

Bonjour
Voici le fichier avec l'userform, serait il possible de me dire si tout est ok et mettre les codes pour moi.
merci de votre support

**mercatog** · 09/03/2011, 22h34

serait il possible de me dire si tout est ok et mettre les codes pour moi.

Mais, j'explique par un commentaire le code:
Dans ton userform tu as 3 TextBox
TextBox1 pour date début
TextBox2 pour date fin
TextBox3 pour la mot à chercher dans la colonne J de ta feuille try
La ligne 7 est celle réservée aux titres de colonnes

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
34
35
36
37
38
39
40
41
42
43
44
45
46
Private Sub VALIDER_Click()
Dim Derlg As Long, DD As Long, DF As Long
Dim Sh As Worksheet
 
'On inhibe la mise à jour affichage écran
Application.ScreenUpdating = False
With Sheets("Empl")
    'On supprime l'éventuel filtre automatique
    .AutoFilterMode = False
    'La dernière ligne remplie de la colonna A
    Derlg = .Range("A" & .Rows.Count).End(xlUp).Row
    'Si TextBox1 et TextBox2 sont des dates et TextBox3 non vide
    If IsDate(Me.TextBox1.Value) And IsDate(Me.TextBox2.Value) And Me.TextBox3.Value <> "" Then
        'En DD (date début), On transforme le contenu de TextBox1 en Long
        DD = CLng(DateValue(Me.TextBox1.Text))
        'En DF (date Fin), on transforme le contenu de TextBox2 en Long
        DF = CLng(DateValue(Me.TextBox2.Text))
        'On filtre la colonne A entre DD et DF
        .Range("A7:J" & Derlg).AutoFilter field:=1, Criteria1:=">=" & DD, Criteria2:="<=" & DF, Operator:=xlAnd
        'Et on filtre la colonne J sur le texte entrée dans TextBox3
        .Range("A7:J" & Derlg).AutoFilter field:=10, Criteria1:=Me.TextBox3.Text
        'Si le résultat du filtre comporte plus d'une ligne (y compris la ligne 7, celle des titres)
        If .Range("A7:A" & Derlg).SpecialCells(xlCellTypeVisible).Count > 1 Then
            On Error Resume Next
            'Si la feuille nommée par la valeur de TextBox3 existe, on instancie dans Sh cette feuille
            Set Sh = Sheets(Me.TextBox3.Text)
            On Error GoTo 0
            'Si la feuille nommée par la valeur de TextBox3 n'existe pas, Sh est vide (nothing)
            If Sh Is Nothing Then
                'On crée une nouvelle feuille qu'on nomme par la valeur de textbox3
                Set Sh = Worksheets.Add(After:=Worksheets(1))
                Sh.Name = Me.TextBox3.Text
                'on copie la ligne 7 des titres dans la nouvelle feuille créée
                .Rows(7).Copy Sh.Range("A1")
            End If
            'On copie le résultat issu du filtre dans la première ligne vide de la feuille Sh
            .Range("A8:J" & Derlg).SpecialCells(xlCellTypeVisible).Copy Sh.Cells(Sh.Rows.Count, 1).End(xlUp)(2)
            Set Sh = Nothing
        End If
    End If
    'On supprime le filtre automatique précédent
    .AutoFilterMode = False
End With
'on ferme l'userform
Unload Me
End Sub

**duplaly** · 15/03/2011, 16h05

bonjour
merci beaucoup pour le code.
À la place des textbox pour saisir la date, je voudrais utiliser 2 DTPicker. Je suppose que le code doit être modifié un peu.
J'apprécierais un peu d'aide.

**mercatog** · 15/03/2011, 18h29

Bonjour

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
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
Private Sub VALIDER_Click()
Dim Derlg As Long, DD As Long, DF As Long
Dim Sh As Worksheet
 
'On inhibe la mise à jour affichage écran
Application.ScreenUpdating = False
With Sheets("Empl")
    'On supprime l'éventuel filtre automatique
    .AutoFilterMode = False
    'La dernière ligne remplie de la colonna A
    Derlg = .Range("A" & .Rows.Count).End(xlUp).Row
    'Si TextBox3 non vide
    If Me.TextBox3.Value <> "" Then
        'En DD (date début), On transforme le contenu de DTPicker1 en Long
        DD = CLng(Me.DTPicker1.Value)
        'En DF (date Fin), on transforme le contenu de DTPicker2 en Long
        DF = CLng(Me.DTPicker2.Value)
        If DF > DD Then
            'On filtre la colonne A entre DD et DF
            .Range("A7:J" & Derlg).AutoFilter field:=1, Criteria1:=">=" & DD, Criteria2:="<=" & DF, Operator:=xlAnd
            'Et on filtre la colonne J sur le texte entrée dans TextBox3
            .Range("A7:J" & Derlg).AutoFilter field:=10, Criteria1:=Me.TextBox3.Text
            'Si le résultat du filtre comporte plus d'une ligne (y compris la ligne 7, celle des titres)
            If .Range("A7:A" & Derlg).SpecialCells(xlCellTypeVisible).Count > 1 Then
                On Error Resume Next
                'Si la feuille nommée par la valeur de TextBox3 existe, on instancie dans Sh cette feuille
                Set Sh = Sheets(Me.TextBox3.Text)
                On Error GoTo 0
                'Si la feuille nommée par la valeur de TextBox3 n'existe pas, Sh est vide (nothing)
                If Sh Is Nothing Then
                    'On crée une nouvelle feuille qu'on nomme par la valeur de textbox3
                    Set Sh = Worksheets.Add(After:=Worksheets(1))
                    Sh.Name = Me.TextBox3.Text
                    'on copie la ligne 7 des titres dans la nouvelle feuille créée
                    .Rows(7).Copy Sh.Range("A1")
                End If
                'On copie le résultat issu du filtre dans la première ligne vide de la feuille Sh
                .Range("A8:J" & Derlg).SpecialCells(xlCellTypeVisible).Copy Sh.Cells(Sh.Rows.Count, 1).End(xlUp)(2)
                Set Sh = Nothing
            End If
        End If
    End If
    'On supprime le filtre automatique précédent
    .AutoFilterMode = False
End With
'on ferme l'userform
Unload Me
End Sub

**duplaly** · 15/03/2011, 21h49

Merci beaucoup. Tout fonctionne nickel

Besoin Usf qui permet recherche selon intervalle de date [XL-2010]

Macros et VBA Excel

Discussions similaires

Partager

Partager