Microsoft 365 atteindre la 1ère date égale ou supérieure à aujourd'hui

[Usine à gaz]

Bonjour à toutes et à tous,
J'espère que vous allez bien

J'ai besoin dans mon fichier d'atteindre la cellule qui contient la 1ère date égale ou supérieure à aujourd’hui.

J'ai fait pas mal de tests sans succès ... bcp de recherches et j'ai trouvé un code sur le forum :

Macro trouvant la date la plus proche

Bonjour les « Forumers » du samedi, Plusieurs posts traitent du pb. mais je n’ai pas trouvé de solution exacte à ce que je cherche, aussi je me permets de vous l’exposer. Soit une plage A1 à A10 qui recense, dans l’ORDRE CHRONOLOGIQUE, une série de jours fériés. Je saisis une date aléatoire...

www.excel-downloads.com

#Post de CBernardT en 2006 que je remercie au passage

J'ai modifié le code pour qu'il corresponde au besoin de mon fichier.
ça fonctionne mais c'est très long et je ne sais pas comment l'améliorer.
J'ai joint un fichier qui contient une douzaine de milliers de lignes .... dans mon fichier de travail c'est 60.000 lignes et +++ et ce serait c'est très très très long
Auriez-vous une solution pour ce que soit plus rapide ?
Avec mes remerciements,
Je vous souhaite une belle journée,
Amicalement,
lionel,

 

[job75]

Je trouve cette solution plus élégante :

Sub ChercheDate()
Dim c As Range, dat As Date
On Error Resume Next 'si aucune SpecialCell
With [J:J].SpecialCells(xlCellTypeVisible)
    For dat = Int(Application.Min(Date, Application.Max(.Cells))) To Int(Application.Min(.Cells)) Step -1
        Set c = .Find(dat, , xlFormulas, xlPart, , IIf(dat = Date, xlNext, xlPrevious))
        If Not c Is Nothing Then
            c.Select 'pour tester
            Exit For
        End If
    Next
End With
End Sub

 

[Usine à gaz]

lol, merci Gérard, je la teste

 

[Usine à gaz]

Re-Gérard,
ça marche aussi nickel
lionel,

 

[job75]

Chez moi la recherche d'une date sur 65 000 par la méthode Find prend au maximum 0,05 seconde.

Cela veut dire que la macro précédente peut prendre 1 seconde si 20 itérations de la boucle.

La solution par tableau VBA sera bien sûr beaucoup plus rapide.

 

[Usine à gaz]

Re-Gérard,
Chez moi les 2 codes sont également hyper rapides quasi instantanés
lionel,

 

[job75]

Cela dépend de la configuration, mes codes peuvent prendre trop de temps.

 

[Usine à gaz]

OUI, certainement mais ça fonctionne bien chez moi

 

[job75]

OUI, certainement mais ça fonctionne bien chez moi

C'est pour ça que j'ai dit au post #29 que c'est jouable.

Bonne nuit.

 

[Usine à gaz]

Tout à fait, ça marche et c'est rapide chez moi après pas mal de tests.

 

[job75]

Avec un tableau VBA ce n'est pas toujours le plus rapide mais c'est la sécurité :

Sub ChercheDate()
Dim cible As Date, P As Range, tablo, i&, x As Variant, lig&, maxi As Date
cible = Date 'modifiable
Set P = Intersect(ActiveSheet.UsedRange, [J:J])
If P Is Nothing Then Exit Sub
tablo = P.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
For i = 1 To UBound(tablo)
    x = tablo(i, 1)
    If IsDate(x) Then
        If x < cible + 1 Then
            If Not P(i).Rows.Hidden Then
                If Int(x) = cible Then
                    lig = i
                    Exit For
                ElseIf x > maxi Then
                    maxi = x
                    lig = i
                End If
            End If
        End If
    End If
Next
If lig Then P(lig).Select 'pour tester
End Sub

Sur 65 000 lignes la durée maximum d'exécution sera de 0,5 seconde chez moi.

Quelle que soit l'ordre des dates, quelles que soient les lignes masquées.

Re-bonne nuit.

 

[Usine à gaz]

Encore Merci Gérard,
Je testerai.
Bonne nuit à toi aussi
lionel,

 

[Usine à gaz]

ça fonctionne nickel et je ne remarque pas la différence de rapidité
Re-Bonne nuit Gérard
lionel,

 

[job75]

Bonjour Lionel, le forum,

Ce n'était pas fini, il y a mieux.

Sur 65 000 lignes cette macro s'exécute en 0,05 seconde, elle est donc 10 fois plus rapide :

Sub ChercheDate()
Dim cible As Date, P As Range, tablo, i&, x As Variant, lig&, maxi As Date
cible = Date 'modifiable
Set P = Intersect(ActiveSheet.UsedRange, [J:J])
If P Is Nothing Then Exit Sub
Application.ScreenUpdating = False
On Error Resume Next 'si aucune SpecialCell
P.Columns(2).Insert xlToRight 'insère une colonne auxiliaire
P.Columns(2).SpecialCells(xlCellTypeVisible) = True 'repérage des lignes visibles
tablo = P.Resize(, 2) 'matrice, plus rapide
For i = 1 To UBound(tablo)
    x = tablo(i, 1)
    If IsDate(x) Then
        If x < cible + 1 Then
            If tablo(i, 2) Then 'si ligne visible
                If Int(x) = cible Then
                    lig = i
                    Exit For
                ElseIf x > maxi Then
                    maxi = x
                    lig = i
                End If
            End If
        End If
    End If
Next
P.Columns(2).Delete xlToLeft 'supprime la colonne auxiliaire
Application.ScreenUpdating = True
If lig Then P(lig).Select 'pour tester
End Sub

Bonne journée.

 

[Usine à gaz]

Bonjour Gérard, le Forum,
J'espère que tout le monde va pour le mieux

Merci Gérard, pour ce code

effectivement très rapide et qui fonctionne nickel
Bonne journée Gérard, à toutes et à tous,
lionel,

 

[job75]

Bah toutes mes macros traitent le problème de la 1ère date égale ou inférieure à aujourd'hui.

Si l'on veut la 1ère date supérieure à aujourd'hui il faut toutes les revoir, c'est un bon exercice.

Pour la dernière macro :

Sub ChercheDate()
Dim cible As Date, P As Range, mini As Date, tablo, i&, x As Variant, lig&
cible = Date 'modifiable
Set P = Intersect(ActiveSheet.UsedRange, [J:J])
If P Is Nothing Then Exit Sub
mini = Application.Max(P)
Application.ScreenUpdating = False
On Error Resume Next 'si aucune SpecialCell
P.Columns(2).Insert xlToRight 'insère une colonne auxiliaire
P.Columns(2).SpecialCells(xlCellTypeVisible) = True 'repérage des lignes visibles
tablo = P.Resize(, 2) 'matrice, plus rapide
For i = 1 To UBound(tablo)
    x = tablo(i, 1)
    If IsDate(x) Then
        If x >= cible Then
            If tablo(i, 2) Then 'si ligne visible
                If Int(x) = cible Then
                    lig = i
                    Exit For
                ElseIf x < mini Then
                    mini = x
                    lig = i
                End If
            End If
        End If
    End If
Next
P.Columns(2).Delete xlToLeft 'supprime la colonne auxiliaire
Application.ScreenUpdating = True
If lig Then P(lig).Select 'pour tester
End Sub