Fichier Excel : Retenir les dates les plus récentes par millésimes

nahtalie · 14 Avril 2009

Hello,

Catrice un nouveau défi pour toi (et pour les autres aussi).

J'ai un tableau Excel avec plusieurs dates d'arrêté comptable pour des années différentes et pour chaque année je souhaite retenir la date la plus récente (ne garder que ces lignes là) automatiquement, sans avoir a y revenir dessus à chaque fin de trimestre (pas de manuel).

par exemple :

Dates d'arrêtés
31/03/2006
30/06/2006
30/09/2006
31/12/2006 (on garde que cette ligne pour 2006)
31/03/2007
30/06/2007
30/09/2007
31/12/2007 (on garde que cette ligne pour 2007)
31/03/2008
30/06/2008
30/09/2008
31/12/2008 (on garde que cette ligne pour 2008)
31/03/2009 (on garde que cette ligne pour 2009)

par contre à fin juin j'aurais :

31/03/2009
30/06/2009 (et je ne garderais que celle là)
etc...

Voila j'espère que je suis claire,
sinon j'envoie le fichier.

D'avance un grand merci pour votre aide,
++
nat🙂

ps : zetes les meilleurs!

pierrejean · 17 Avril 2009

Re : Fichier Excel : Retenir les dates les plus récentes par millésimes

bonjour Nathalie

Salut CATRICE
Salut Fo_rum

derniere version avec suppression des S09

Chez moi moins de 4 secondes et 1762 lignes
si vous avez un resultat sans S09 pouvez vous confirmer le nbre de lignes du resultat ?

Code:

Sub essai3()
Application.ScreenUpdating = False
Range("A3:O" & Range("A65536").End(xlUp).Row).Sort Key1:=Range("K3"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Dim tablign()
Dim coll As Collection
Set coll = New Collection
For N = 3 To Range("K65536").End(xlUp).Row
     On Error Resume Next
       coll.Add Year(Range("K" & N)), CStr(Year(Range("K" & N)))
     On Error GoTo 0
Next N
ReDim tablign(1 To coll.Count)
For N = 1 To coll.Count
  For m = 1 To Range("K65536").End(xlUp).Row
    If IsDate(Range("K" & m)) Then
     If Year(Range("K" & m)) = coll(N) And tablign(N) < Range("K" & m) Then
      tablign(N) = Range("K" & m)
     End If
    End If
  Next m
Next N
For N = LBound(tablign) To UBound(tablign)
 lesdates = lesdates & tablign(N) & "-"
Next N
Tablo = Range("A3:O" & Range("A65536").End(xlUp).Row)
For N = LBound(Tablo) To UBound(Tablo) - 1
  If Tablo(N, 1) = "S09" Then Tablo(N, 1) = ""
  If InStr(lesdates, Tablo(N, 11)) = 0 Then Tablo(N, 1) = ""
Next N
Range("A3:O" & Range("A65536").End(xlUp).Row).ClearContents
ligne = 3
For N = LBound(Tablo) To UBound(Tablo)
 If Tablo(N, 1) <> "" Then
  For m = LBound(Tablo, 2) To UBound(Tablo, 2)
    Cells(ligne, m) = Tablo(N, m)
  Next m
  ligne = ligne + 1
 End If
Next N
Application.ScreenUpdating = True
End Sub

nahtalie · 17 Avril 2009

Re : Fichier Excel : Retenir les dates les plus récentes par millésimes

Fo_rum à dit:
Re,

Ce ne sont pas mes états d'âme que j'expose ! Mais quand bien même !
Le nombre de demandeurs mal-polis, exigeants, ..., indélicats est en progression constante donc mes interventions sont inversement proportionnelles à celui-ci !
Je ne change pas un mot de mon message précédent d'autant plus tu fais partie de ceux qui multiplient les changements au fil des fils !

Salut Fo_rum,
Je n'ai pas eu l'impression d'être mal polie, exigeante ou indélicate, au contraire.

ça tombe bien que tu parle de fil, c'est quoi exactement ?

J'ai des soucis à résoudre très vite, et j'ai pas eu le temps de tout lire et tout comprendre. Dès que possible j'ai bien l'intention de m'y mettre plus sérieusement car j'aimerais avoir le 1/10e de niveau que vous possédez au niveau macro.

Au fait, j'ai regardé ta macro.
Merci en plus tu es de ceux qui mette des commentaires, bravo.

Tu as raison de ne pas changer un mot de ton précédent message, faut être très sévère avec les petits nouveaux et je comprends que ça doit saoûler à force de répéter toujours les mêmes choses.

En tout cas je ne change rien à mes excuses non plus.

++
nat🙂

nahtalie · 17 Avril 2009

Re : Fichier Excel : Retenir les dates les plus récentes par millésimes

pierrejean à dit:

bonjour Nathalie

Salut CATRICE
Salut Fo_rum

derniere version avec suppression des S09

Chez moi moins de 4 secondes et 1762 lignes
si vous avez un resultat sans S09 pouvez vous confirmer le nbre de lignes du resultat ?

Code:

Sub essai3()
Application.ScreenUpdating = False
Range("A3:O" & Range("A65536").End(xlUp).Row).Sort Key1:=Range("K3"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Dim tablign()
Dim coll As Collection
Set coll = New Collection
For N = 3 To Range("K65536").End(xlUp).Row
     On Error Resume Next
       coll.Add Year(Range("K" & N)), CStr(Year(Range("K" & N)))
     On Error GoTo 0
Next N
ReDim tablign(1 To coll.Count)
For N = 1 To coll.Count
  For m = 1 To Range("K65536").End(xlUp).Row
    If IsDate(Range("K" & m)) Then
     If Year(Range("K" & m)) = coll(N) And tablign(N) < Range("K" & m) Then
      tablign(N) = Range("K" & m)
     End If
    End If
  Next m
Next N
For N = LBound(tablign) To UBound(tablign)
 lesdates = lesdates & tablign(N) & "-"
Next N
Tablo = Range("A3:O" & Range("A65536").End(xlUp).Row)
For N = LBound(Tablo) To UBound(Tablo) - 1
  If Tablo(N, 1) = "S09" Then Tablo(N, 1) = ""
  If InStr(lesdates, Tablo(N, 11)) = 0 Then Tablo(N, 1) = ""
Next N
Range("A3:O" & Range("A65536").End(xlUp).Row).ClearContents
ligne = 3
For N = LBound(Tablo) To UBound(Tablo)
 If Tablo(N, 1) <> "" Then
  For m = LBound(Tablo, 2) To UBound(Tablo, 2)
    Cells(ligne, m) = Tablo(N, m)
  Next m
  ligne = ligne + 1
 End If
Next N
Application.ScreenUpdating = True
End Sub

Salut Pierre Jean,

Merci pour ton aide,
je regarde ça dès que possible (en début d'après midi, j'espère.

++
nat🙂

nahtalie · 17 Avril 2009

[résolu]Re : Fichier Excel : Retenir les dates les plus récentes par millésimes

Catrice à dit:
@ Fo_rum
J'ai testé ton code sur ma machine => 23 s et derniere ligne = 2453
Le mien => 1:06 et derniere ligne = 2449

J'ai enlevé les 1900 de la colonne L et refait le test.
Ton code => 15 s
Le mien => 10 s !?
Pierrejean => 41 s et derniere ligne 2449 (avec les lignes 1900 j'avais un pb. donc testé que dans cette configuration)

J'avais du faire le test dans cette configuration.
en tous cas ça vaut le coup de supprimer ces dates 😉

Il y a 4 lignes de différences à checker ...

@nathalie
Pourras tu dire si finalement tu as obtenu ce que tu voulais ?

Bonjour Catrice,

Merci pour ton message.

Je pense que oui, (reste juste à voir la dernière macro de Pierre Jean)
Je le fais dès le début de cette après midi.

J'ai cru comprendre que je "polluais", désolée!

N'hésites pas à me dire ce que je dois faire pour avoir une conduite exemplaire.
Ce forum est super intérressant j'ai appris plein de truc et j'aimerais bien continuer d'apprendre avec vous.
C'est vrai que je n'ai pas eu le temps de tout lire, pressée par mes problèmes.

++
nat🙂

ps : j'ai mis résolu dans le titre de mon message pensant bien faire.

nahtalie · 17 Avril 2009

Re : Fichier Excel : Retenir les dates les plus récentes par millésimes

pierrejean à dit:

bonjour Nathalie

Salut CATRICE
Salut Fo_rum

derniere version avec suppression des S09

Chez moi moins de 4 secondes et 1762 lignes
si vous avez un resultat sans S09 pouvez vous confirmer le nbre de lignes du resultat ?

Code:

Sub essai3()
Application.ScreenUpdating = False
Range("A3:O" & Range("A65536").End(xlUp).Row).Sort Key1:=Range("K3"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Dim tablign()
Dim coll As Collection
Set coll = New Collection
For N = 3 To Range("K65536").End(xlUp).Row
     On Error Resume Next
       coll.Add Year(Range("K" & N)), CStr(Year(Range("K" & N)))
     On Error GoTo 0
Next N
ReDim tablign(1 To coll.Count)
For N = 1 To coll.Count
  For m = 1 To Range("K65536").End(xlUp).Row
    If IsDate(Range("K" & m)) Then
     If Year(Range("K" & m)) = coll(N) And tablign(N) < Range("K" & m) Then
      tablign(N) = Range("K" & m)
     End If
    End If
  Next m
Next N
For N = LBound(tablign) To UBound(tablign)
 lesdates = lesdates & tablign(N) & "-"
Next N
Tablo = Range("A3:O" & Range("A65536").End(xlUp).Row)
For N = LBound(Tablo) To UBound(Tablo) - 1
  If Tablo(N, 1) = "S09" Then Tablo(N, 1) = ""
  If InStr(lesdates, Tablo(N, 11)) = 0 Then Tablo(N, 1) = ""
Next N
Range("A3:O" & Range("A65536").End(xlUp).Row).ClearContents
ligne = 3
For N = LBound(Tablo) To UBound(Tablo)
 If Tablo(N, 1) <> "" Then
  For m = LBound(Tablo, 2) To UBound(Tablo, 2)
    Cells(ligne, m) = Tablo(N, m)
  Next m
  ligne = ligne + 1
 End If
Next N
Application.ScreenUpdating = True
End Sub

resalut Pierre Jean,
resalut Catrice,

Nickel chrome!
Elle a mis 2 sc a tourner en plus.

Merci
++
nat🙂

Catrice · 17 Avril 2009

Re : Fichier Excel : Retenir les dates les plus récentes par millésimes

@nahtalie,

Pour ma part, tu ne pollues rien du tout 😉
Personnellement, j'ai des seaux remplis de Fil pour lesquels je n'ai jamais eu de réponse ou de feedback et tout baigne.
(Fil = sujet qui est ouvert; Post = 1 intervention sur un Fil. pour moi en tous cas)

Fichier Excel : Retenir les dates les plus récentes par millésimes

nahtalie

Guest

pierrejean

XLDnaute Barbatruc

nahtalie

Guest

nahtalie

Guest

nahtalie

Guest

nahtalie

Guest

Catrice

XLDnaute Barbatruc

Discussions similaires

Fichier Excel : Retenir les dates les plus récentes par millésimes

nahtalie

Guest

pierrejean

XLDnaute Barbatruc

nahtalie

Guest

nahtalie

Guest

nahtalie

Guest

nahtalie

Guest

Catrice

XLDnaute Barbatruc

Discussions similaires

Privacy & Transparency

Privacy & Transparency