Discussion :

[Ma4dNes]

Finalement mon jeu de données comporte 85424 lignes à traiter (je ne sais pas d'où j'ai sorti les 240000) et seulement 30074 lignes dans la feuille de recherche (il me manque des données)...
Donc avant optimisation et avant que je vois une grosse erreur dans mon code il fallait à peu près 14h......
Après optimisation il ne faut plus que 2455,57s soit 41min !!!!!!!!!!!
En sachant qu'à chaque fois que le numéro de container n'est pas trouvé cela ralentit beaucoup le code donc avec des données complètes cela devrai prendre encore moins de temps.
Merci à tous.


Pour info

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
63
64
65
66
67
68
69
70
71
72
73
Private Declare Function QueryPerformanceCounter Lib "Kernel32" (X As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "Kernel32" (X As Currency) As Boolean
 
Sub exec()
 
Dim i As Long, i_max As Long, cont As String, dater As Date, c As Range, t As Integer, start As Range
 
'---------------------------------------------------------------------------------------
        Dim Debut As Currency, Fin As Currency, Freq As Currency
 
        QueryPerformanceCounter Debut
'---------------------------------------------------------------------------------------
 
i_max = Feuil6.Cells(2, 1).CurrentRegion.Rows.Count + 1
Set start = Feuil8.Range("E1")
 
For i = 3 To i_max
cont = Feuil6.Cells(i, 4).Value
dater = Feuil6.Cells(i, 10).Value
    With Feuil8.Range("E:E")                                 'Tableau_BDsuivi_filtre_be.accdb
        Set c = .Find(cont, After:=start, LookIn:=xlValues, LookAt:=xlWhole) '
        If Not c Is Nothing Then
            firstAddress = c.Address
            t = 0
            Do
                If Feuil8.Cells(c.Row, 2) <> 0 And dater <> 0 Then
                    If Feuil8.Cells(c.Row, 2).Value >= dater Then
                        Feuil6.Cells(i, 16) = Feuil8.Cells(c.Row, 2)
                        Feuil6.Cells(i, 13) = Feuil8.Cells(c.Row, 4)
                        Feuil6.Cells(i, 17) = Feuil8.Cells(c.Row, 3)
                        Set start = Feuil8.Cells(c.Row - 1, 5)
                        t = 1
 
'--------------------------------------------------------------
        Debug.Print "i = " & i
        Debug.Print "c = " & c.Address
        Debug.Print "start = " & start.Address
'--------------------------------------------------------------
 
                    Else
                        Set c = .FindNext(c)
 
                        If c Is Nothing Then
                            t = 1
                        End If
                    End If
                Else
                    Set cel = c
                    t = 1
                End If
            Loop While t = 0 And c.Address <> firstAddress
        End If
    End With
    If Feuil6.Cells(i, 16).Value = "" Then
        Feuil6.Cells(i, 16) = "NOPE"
        Feuil6.Cells(i, 13) = "NOPE"
        Feuil6.Cells(i, 17) = "NOPE"
 
'---------------------------------------------------------------------------------------
        Debug.Print "i = " & i
        Debug.Print "start = " & start.Address
'---------------------------------------------------------------------------------------
 
    End If
Next i
 
'---------------------------------------------------------------------------------------
        QueryPerformanceCounter Fin
        QueryPerformanceFrequency Freq
        MsgBox "Durée de la procédure = " & Format(((Fin - Debut) / Freq), "0.00") & " s"
'---------------------------------------------------------------------------------------
 
End Sub

[RyuAutodidacte]

Bonjour,

En passant par collections et tableaux je pense que tu mettrais moins de 3 min si pas moins …

[Ma4dNes]

Je vais regarder mais je précise encore que je suis un vrai novice en excel et VBA. De toute façon ce code ne servira qu'une seule fois, pour préparer les données à être injectées dans la nouvelle BDD.

[Gfacro]

Bonjour,
Idée rapide à développer :
Tu tries (A>Z) les dates, puis tu tries (A>Z) les ID. Tu as donc des blocs avec les ID, et dans chaque bloc d'ID, les dates sont triées du plus ancien au plus récent.
Ensuite, il te suffit pour un ID donné, de trouver la première occurence de cet ID (méthode Application.Match ou Range.Find). A partir de là, tu parcours les dates du bloc de l'ID et tu t'arrêtes à la première date postérieure à la date de référence --> boucle while avec 2 conditions : on a le même ID et on s'arrête dès que la date est postérieure à la date de référence. Tu comprends ?

J'avoue ne pas avoir tout lu avec attention. Depuis le départ, je ne comprend pas bien l'utilité de cette recherche puisque les données des deux feuilles sont triées sur le numéro de contenaire si j'ai bien compris.
si vous voulez faire des aller-retours sur toutes les lignes de votre contenaire, il vous suffit de garder en mémoire la première ligne de votre contenaire et parcourir les lignes suivantes jusqu'à ce que cet identifiant change.
Si vous n'avez pas besoin de faire des allers-retours, il suffit de vérifier le numéro du contenaire de la ligne suivante (ou précédente selon votre besoin).

et ce pour les deux feuilles éventuellement. Un principe de synchronisation entre les deux feuilles.

[RyuAutodidacte]

Bonsoir,

PS :
- Pour le Timer on peut utiliser directement VBA
- Sachant que ton nombre de lignes dépasse les 65536 (qui est la limite à Application.Index) j'ai fait une fonction permettant d'avoir le même type de résultat, comme cela on copie seulement sur les colonnes incriminées

Comme le sujet n'est pas mis en résolu, voilà une démo2 comme je l'ai fait un peu en aveugle n'étant pas sur d'avoir toutes les informations mais pour le principe tout y est normalement :

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
Sub Demo2()
Dim F8, F6, Coll As New Collection, L$, D(), Lig(), i&, j&, Ligne, N As Integer, dater, T!
 
    F8 = Feuil8.UsedRange.Value
    F6 = Feuil6.UsedRange.Value
 
    T = Timer
 
        On Error Resume Next
        For i = 2 To UBound(F8)
            Coll.Add i, CStr(F8(i, 5))
            If Err Then
                L = Coll(F8(i, 5))
                Coll.Remove F8(i, 5):       Coll.Add L & " " & i, CStr(F8(i, 5))
            End If
            Err.Clear
        Next
 
        For i = 3 To UBound(F6)
            Coll (F6(i, 4))
            If Err.Number = 0 Then
                a = Split(Coll(F6(i, 4)), " ")
                For j = 0 To UBound(a)
                    If CDate(F8(a(j), 2)) >= CDate(F6(i, 10)) Then
                        N = N + 1:       ReDim Preserve D(1 To N):       ReDim Preserve Lig(1 To N)
                        D(N) = CLng(CDate(F8(a(j), 2))):       Lig(N) = a(j)
                    End If
                Next
                dater = CDate(Application.Min(D))
                If Not Err Then
                    Ligne = CLng(Lig(Application.Match(CLng(dater), D, 0)))
                    F6(i, 16) = dater
                    F6(i, 17) = F8(Ligne, 3)
                    F6(i, 13) = F8(Ligne, 4)
                End If
            End If
            If F6(i, 16) = "" Then
                F6(i, 16) = "NO"
                F6(i, 17) = "NO"
                F6(i, 13) = "NO"
            End If
            Err.Clear:    N = 0:    dater = "":    Ligne = "":    Erase D, Lig
        Next
        On Error GoTo 0
 
    Application.ScreenUpdating = False
        Res = Index_Tab(F6, 3, 13):    Feuil6.Cells(3, 13).Resize(UBound(Res), UBound(Res, 2)) = Res:    Erase Res
        Res = Index_Tab(F6, 3, 16, 17):    Feuil6.Cells(3, 16).Resize(UBound(Res), UBound(Res, 2)) = Res:    Erase Res
    Application.ScreenUpdating = True
 
    MsgBox "Temps d'execution : " & Format(Timer - T, "0.000 s")
End Sub
 
Function Index_Tab(VA As Variant, Entete As Byte, ParamArray Arr()) 'Les paramètres : 1- Variable tableau | 2- Entete (afin de la supprimer ou pas) Í 3-Array (colonne voulu de la variable tableau, ex : 4, 7, 9)
Dim VB(), i&, j&
    ReDim VB(1 To UBound(VA) - Entete + 1, 1 To UBound(Arr) + 1)
    For i = Entete To UBound(VA)
        For j = 1 To UBound(Arr) + 1:    VB(i - Entete + 1, j) = VA(i, Arr(j - 1)):    Next
    Next
    Index_Tab = VB
End Function

Voilà

Edit : je remet le bon code, j'ai pas copier le bon

[RyuAutodidacte]

Bonjour Ma4dNes,

J'ai testé ton code, et j'ai remarqué 2 choses qui vont peut-être poser problème si tu as le même résultat dans ton fichier.
Pour cela j'ai créé un fichier avec de fausses donné seulement sur les colonnes incriminées.
La première chose, c'est que lorsque ton code est terminé il ajoute une ligne après la dernière ligne, en rajoutant des Nope.
La deuxième chose, sur :

Code :

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

                    If Feuil8.Cells(c.Row, 2).Value >= dater Then

La valeur égal n'est pas forcément pris en compte :
Si on a 17/08/17 et 18/08/17 en Feuil8 et 17/08/17 pour dater
Le résultat pourra être 18/08/17 et non 17/08/17

PS : dans mon code j'ai utilisé dater pour le résultat en Feuil6 sur Cells(i, 16)

As tu testé mon code. Qu'en est-il ?

[Ma4dNes]

OK, 5.31s
Je ne sais pas trop si je suis en joisse ou dégoutté
Plus qu'à décortiquer ton code pour le comprendre. Du coup merci beaucoup. je clorai la discussion quand les résultats auront étés validés.

[RyuAutodidacte]

Re,

Explication du code dans les grandes lignes :

• Ligne 4 et 5 : on créé les variables tableau des données en Feuille 8 et 6
appelées F8 et F6 pour un meilleurs discernement

• Ligne 9 à 17 : on utilise une collection (voir la gestion des doublons/et des erreurs dans la Faq - supprime les doublons) sur la variable tableau F8
ce qui permet de créer une clé unique pour chaque container dont l'item sera le n° de ligne
Dans le cas où l'on rencontre le même container on récupère le n° de ligne, on efface la clé
et on la rajoute de nouveau en ajoutant le nouveau N° de ligne en sus de la ligne ou les lignes déjà récupérer

• Ligne 19 à 43 : on parcourt les containers de la Feuil6 et on vérifie dans la collection si la clé existe.
si elle n'existe pas on a une erreur (voir la gestion des erreurs avec les collections dans faq), et donc on n'a pas de date
si elle existe on récupère l'item (où il y a le ou les n° de lignes),
on split l'item afin d'avoir une mini variable tableau afin de récupérer les n° de séries des dates supérieures ou égal et le n° de lignes les concernants
par rapport à date de container clé visé en feuil6.
On fait un MIN pour sélectionner la date la plus proche à la date du container en Feuil6
puis on récupère son numéro de ligne afin de faire correspondre les valeurs dans les cellules voulus.

Bon pour le reste je te laisse voir, je vais être très occupé et pas dispo, je regarderai ton retour

Ryu

[Ma4dNes]

Vérifications OK, tout va bien merci à tous.

[RyuAutodidacte]

Bonjour,
Pour la compréhension du code ça été ?