Discussion :

[BERRACHED SAID]

bonjour le forum et bonne journée

je voudrais faire une extraction sur une base de données se trouvant dans la feuille nommée "Polices" cette extraction repose sur 3 critères N°de Client et Date de début puis Date Fin puis transférer le résultat sur une autre feuille nommée "INTERFACE" j'avais un code qui est sur la même logique seulement le résultat est transférer dans un listview j'ai voulu l'adapter
pour qu'il transfère une dans feuille de calcul au lieu d'un listview mais en vain je galère depuis ce matin.

merci a vous et bonne journée mes amis.

voici le code en question :

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
49
50
51
52
53
54
55
56
57
58
59
60
61
62
Private Sub CommandButton1_Click()
'On Error Resume Next
Dim wsBD As Worksheet
    Dim derLig As Long
    Dim Lig As Long
    Dim plage As Range
    Dim CritRente As String
    Dim CritDateDeb As String
    Dim CritDateFin As String
    Dim LigList As Long
    Dim Cumul As Currency
    Dim nc As Integer, s As String
 
    s = Trim(TextBox3): nc = Len(s)
    If nc = 0 Then Exit Sub
    Set wsBD = Worksheets("Polices")
    ' Dernière ligne dans la feuille BD
    derLig = wsBD.Range("A" & Cells.Rows.Count).End(xlUp).Row
    If derLig < 2 Then Exit Sub
 
    ' Définition de la plage en colonne A
    Set plage = wsBD.Range("A2:A" & derLig)
 
    ' Définition des critères
        ' N° De client
    CritRente = IIf(TextBox3.Value = "", "*", TextBox3.Value)
 
        ' Date Début
    CritDateDeb = TextBox1.Value
    If TextBox1.Value = "" Or Not IsDate(TextBox1.Value) Then
        CritDateDeb = Format(Application.WorksheetFunction.Min(plage), "dd/mm/yyyy")
    End If
        ' Date Fin
    CritDateFin = TextBox2.Value
    If TextBox2.Value = "" Or Not IsDate(TextBox2.Value) Then
        CritDateFin = Format(Application.WorksheetFunction.Max(plage), "dd/mm/yyyy")
    End If
    CritDateFin = DateAdd("d", 1, CritDateFin)
    'LigList = 1
    ' Vider la listview
    'ListView1.ListItems.Clear
 
    ' Boucle sur toutes les lignes
    For Lig = 2 To derLig
        ' Rechercher par rapport aux critères
        If CDate(wsBD.Range("B" & Lig).Value) >= CDate(CritDateDeb) And _
            CDate(wsBD.Range("B" & Lig).Value) < CDate(CritDateFin) And _
            CStr(wsBD.Range("A" & Lig).Value) Like CritRente Then
            ' Remplir la première colonne de la feuille INTERFACE
            With Sheets("Interface")
             LigList = .Range("A65000").End(xlUp).Row + 1
            .Range("A10" & LigList) = wsBD.Range("A" & Lig).Value
            .Range("B10" & LigList) = wsBD.Range("E" & Lig).Value
            .Range("C10" & LigList) = wsBD.Range("F" & Lig).Value
            .Range("D10" & LigList) = wsBD.Range("G" & Lig).Value
            .Range("E10" & LigList) = wsBD.Range("H" & Lig).Value
            End With
             LigList = LigList + 1
        End If
    Next Lig
 
End Sub

juste pour votre information la base de données contiens 412264 lignes

[joe.levrai]

Bonjour,

la configuration semble se prêter à l'utilisation (par ordre de préférence) :

- des filtres avancés (AdvanceFilters), un excellent tutoriel de Philippe Tulliez ici http://philippetulliez.developpez.co...dvancedfilter/
- des filtres automatiques (AutoFilters), quelques pistes dans la FAQ http://excel.developpez.com/faq/?pag...eNonVideFiltre


pour les filtres avancés, tu peux exporter le resultat
pour les filtres automatiques, tu peux copier la plage visibles après application du filtre et la mettre dans une autre feuille

et bien sûr, réaliser les choses manuellement pour reproduire le résultat voulu par macro
l'enregistreur de macro fournira ensuite une base à adapter
si tu as besoin d'aide pour adapter le code, prépare-le et montre nous où tu es coincé

ton souhait va tenir sur environ 20 lignes de code (à vue d'oeil), pas plus

[Docmarti]

Bonjour.

Il faut certainement supprimer le "10" dans tes commandes.

Exemple: Remplacer

Code :

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

.Range("A10" & LigList) = wsBD.Range("A" & Lig).Value

par

Code :

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

.Range("A" & LigList) = wsBD.Range("A" & Lig).Value

[BERRACHED SAID]

bonjour Docmarti

merci pour la réponse

effectivement j'ai un peu modifier le code apparemment il marche sauf il me reste 2 choses :

1 - intégrer un message (MsgBox) si bien-sure les données recherchées n'existe pas
2- il est trop lourd dans la recherche est parfois il bloque

si tu as une idée je suis preneur

mille merci

[joe.levrai]

tes deux problèmes ont une résolution quasi-native avec mes propositions, mais je pense avoir parlé dans le vide.

ton code effectue des tests sur chaque cellule, tests consistant en la validation de 3 conditions sur plus de 400 000 lignes

tu m'étonnes que ça soit long .... mes méthodes fonctionnent en quelques instants (voir moins d'une seconde)

[BERRACHED SAID]

bonjour joe.levrai

merci encore de l’intérêt que vous porté a mon problème

voici le code que j'utlise actuellement :

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
49
50
51
52
53
54
55
56
57
58
59
60
 On Error Resume Next
Dim wsBD As Worksheet
    Dim derLig As Long
    Dim Lig As Long
    Dim plage As Range
    Dim CritRente As String
    Dim CritDateDeb As String
    Dim CritDateFin As String
    Dim LigList As Long
    Dim Cumul As Currency
    Dim nc As Integer, s As String
 
    s = Trim(TextBox3): nc = Len(s)
    If nc = 0 Then Exit Sub
    Set wsBD = Worksheets("Polices")
    ' Dernière ligne dans la feuille BD
    derLig = wsBD.Range("A" & Cells.Rows.Count).End(xlUp).Row
    If derLig < 2 Then Exit Sub
 
    ' Définition de la plage en colonne A
    Set plage = wsBD.Range("A2:A" & derLig)
 
    ' Définition des critères
        ' N° De client
    CritRente = IIf(TextBox3.Value = "", "*", TextBox3.Value)
 
        ' Date Début
    CritDateDeb = TextBox1.Value
    If TextBox1.Value = "" Or Not IsDate(TextBox1.Value) Then
        CritDateDeb = Format(Application.WorksheetFunction.Min(plage), "dd/mm/yyyy")
    End If
        ' Date Fin
    CritDateFin = TextBox2.Value
    If TextBox2.Value = "" Or Not IsDate(TextBox2.Value) Then
        CritDateFin = Format(Application.WorksheetFunction.Max(plage), "dd/mm/yyyy")
    End If
    CritDateFin = DateAdd("d", 1, CritDateFin)
     'LigList = 1
    ' Vider la listview
    'ListView1.ListItems.Clear
 
    ' Boucle sur toutes les lignes
        For Lig = 2 To derLig
        ' Rechercher par rapport aux critères
        If CDate(wsBD.Range("B" & Lig).Value) >= CDate(CritDateDeb) And _
            CDate(wsBD.Range("B" & Lig).Value) < CDate(CritDateFin) And _
            CStr(wsBD.Range("A" & Lig).Value) Like CritRente Then
            ' Remplir la première colonne de la feuille INTERFACE
            With Sheets("INTERFACE")
             LigList = .Range("A65000").End(xlUp).Row + 1
            .Range("A" & LigList) = wsBD.Range("A" & Lig).Value
            .Range("B" & LigList) = wsBD.Range("E" & Lig).Value
            .Range("C" & LigList) = wsBD.Range("F" & Lig).Value
            .Range("D" & LigList) = wsBD.Range("G" & Lig).Value
            .Range("E" & LigList) = wsBD.Range("H" & Lig).Value
            End With
             'LigList = LigList + 1
        End If
    Next Lig
     Unload Me

il m'affiche bien le resultat souhaité mais parfois il sort complétement il ne reconnais pas le userform1 et parfois il bug sur
ce macro :

Code :

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

1
2
3
Sub ouvre()
UserForm1.Show
End Sub

il me demande a chaque fois d'enregistrer une copie du classeur

mille merci

[Marc-L]

Bonjour,

avec l'instruction On Error Resume Next masquant les erreurs, difficile !

Suivre le code en mode pas à pas via la touche F8 tout en contrôlant la fenêtre des Variables locales …


_____________________________________________________________________________________________________
Je suis Charlie - Je suis Bardo

[BERRACHED SAID]

bonjour Marc-L

incomplet je comprend pas moi c'est un code que j'avais déjà mais il fonctionne pour Listview je l'ai adapter pour une feuille quant au transfère
ou il est incomplet ???

merci Marc

[joe.levrai]

Sans parler du

il me demande a chaque fois d'enregistrer une copie du classeur

qui a peut-être rendu le fichier instable de part la récupération multiple faite sur le fichier


je reste sur ce que j'ai dis : filtre automatique ou avancé

sinon, c'est mettre un pansement sur une jambe de bois + prendre un vélo pour faire le voyage de Paris vers New-York plutôt que d'utiliser l'avion
(toutes considérations écologiques exclues)

[Philippe Tulliez]

Bonjour,

je reste sur ce que j'ai dis : filtre automatique ou avancé

Comme l'a très bien écrit Joe, je ne peux que te conseiller d'utiliser les filtres avancés.
Après avoir défini les zones Data, de critères et d'exportation, la ligne de code en VBA fait une ligne.

[Marc-L]

J'avais corrigé mon message entre temps Saïd !
Le code du post #6 a l'air incomplet vu qu'il n'y a pas de déclaration de procédure;
mais en remontant sur le post initial …

Retirer la fâcheuse ligne On Error permettra de détecter les erreurs de conception mais de toute manière,
une des deux solutions les plus rapides est bien le filtre ou le filtre avancé, si ce n'est la meilleure …

[BERRACHED SAID]

bonjour le forum et bonne journée

Merci beaucoup pour vos réponses, mon problème d'affichage a été résolu grâce à DoEvents et Me.Repaint et Cela m'a l'air d'un phénomène bien connu pour un affichage dans une boucle longue.

voici le code si ça peut intéressé quelqu’un :

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
49
50
51
52
53
54
55
56
57
58
59
60
61
62
 'On Error Resume Next
Dim wsBD As Worksheet
    Dim derLig As Long
    Dim Lig As Long
    Dim plage As Range
    Dim CritRente As String
    Dim CritDateDeb As String
    Dim CritDateFin As String
    Dim LigList As Long
    Dim Cumul As Currency
    Dim nc As Integer, s As String
 
    s = Trim(TextBox3): nc = Len(s)
    If nc = 0 Then Exit Sub
    Set wsBD = Worksheets("Polices")
    ' Dernière ligne dans la feuille BD
    derLig = wsBD.Range("A" & Cells.Rows.Count).End(xlUp).Row
    If derLig < 2 Then Exit Sub
 
    ' Définition de la plage en colonne A
    Set plage = wsBD.Range("A2:A" & derLig)
 
    ' Définition des critères
        ' N° De client
    CritRente = IIf(TextBox3.Value = "", "*", TextBox3.Value)
 
        ' Date Début
    CritDateDeb = TextBox1.Value
    If TextBox1.Value = "" Or Not IsDate(TextBox1.Value) Then
        CritDateDeb = Format(Application.WorksheetFunction.Min(plage), "dd/mm/yyyy")
    End If
        ' Date Fin
    CritDateFin = TextBox2.Value
    If TextBox2.Value = "" Or Not IsDate(TextBox2.Value) Then
        CritDateFin = Format(Application.WorksheetFunction.Max(plage), "dd/mm/yyyy")
    End If
    CritDateFin = DateAdd("d", 1, CritDateFin)
     'LigList = 1
    ' Vider la listview
    'ListView1.ListItems.Clear
 
    ' Boucle sur toutes les lignes
        For Lig = 2 To derLig
         DoEvents
        ' Rechercher par rapport aux critères
        If CDate(wsBD.Range("B" & Lig).Value) >= CDate(CritDateDeb) And _
            CDate(wsBD.Range("B" & Lig).Value) < CDate(CritDateFin) And _
            CStr(wsBD.Range("A" & Lig).Value) Like CritRente Then
            ' Remplir la première colonne de la feuille INTERFACE
            With Sheets("INTERFACE")
             LigList = .Range("A65000").End(xlUp).Row + 1
            .Range("A" & LigList) = wsBD.Range("A" & Lig).Value
            .Range("B" & LigList) = wsBD.Range("E" & Lig).Value
            .Range("C" & LigList) = wsBD.Range("F" & Lig).Value
            .Range("D" & LigList) = wsBD.Range("G" & Lig).Value
            .Range("E" & LigList) = wsBD.Range("H" & Lig).Value
            End With
             'LigList = LigList + 1
        End If
    Next Lig
    Me.Repaint
     Unload Me

merci mes amis et bonne journée.

Said

[joe.levrai]

Bonjour,

on peut avoir une estimation du temps que met ta procédure pour balayer les 400 000 lignes ?

par ailleurs, dans ton code, tu calcules ta première ligne vide en partant de la ligne 65 000 ... je préfère t'en aviser pour ne pas avoir de mauvaises surprises un jour