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