Rechercher une date et copier une plage de cellules correspondante, sans doublons.

[Okedekpe]

Bonjour à tous,

Malgé cette superbe journée parisienne ( ... ) je ne mettrai pas le pied dehors!
Du coup il me reste excel!

Après plusieurs recherches sur le forum et sur ce site qui m'a d'ailleurs appris beaucoup de choses, je n'arrive pas tout à fait à faire ce que je veux.

J'ai un fichier qui retrace l'historique des valeurs d'un produit.
Ce que j'aimerai faire, c'est de pouvoir copier une partie de cette historique à partir d'une date donnée.

Sub Test()
Dim d As Date

d = "1 / 1 / 2007"
[A:A].Find(What:=d, LookIn:=xlValues).Select
ActiveCell.CurrentRegion.Resize(, 2).Select
Selection.Copy Destination:=Sheets(2).Range("F1")




End Sub

Malheureusement, ce code ne prend pas en compte la date donnée...

De plus, il y a plusieurs valeurs par dates, est ce possible, lors de la suppression des doublons de ne garder que la dernière valeur de chaque date?

Sub doublons()
Dim n As Integer
Sheets(2).Columns("F:F").Select
    Selection.Sort Key1:=Range("F1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
For n = Range("F65536").End(xlUp).Row To 2 Step -1
  On Error Resume Next
  If Range("F" & n) = Range("A" & n - 1) Then
  Rows(n).Delete
  End If
Next n
End Sub

Ce code trouvé ici ne garde pas les dernières valeurs de chaque date.

Je pense qu'il ne manque pas grand chose, mais je sèche...

Je vous joins un fichier avec un onglet pour le fichier original et un onglet avec le résultat souhaité.

Merci d'avance!
A+
Okedekpe

 

[Pierrot93]

Re : Rechercher une date et copier une plage de cellules correspondante, sans doublon

Bonjour,

petite remarque au passage, pour initialiser une variable date en vba :

Dim d As Date
d = #8/3/2011# 'ou 8 est le mois

bonne soirée
@+

 

[BOISGONTIER]

Re : Rechercher une date et copier une plage de cellules correspondante, sans doublon

Bonsoir,

Sub Test()
Dim début
Sheets(1).Select
Dim d As Date
d = #1/3/2007#  ' ou d = DateSerial(2007, 1, 3)
Set début = [A:A].Find(What:=d, LookIn:=xlValues)
If Not début Is Nothing Then Range(début, début.End(xlDown).Offset(, 1)).Copy Sheets(2).Range("F1")
End Sub

Pour méthode rapide, utiliser Dictionary

Sub SupDoublonsGardeDernier()
   Dim i
   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual
   [f1].Sort Key1:=Range("f2"), Order1:=xlAscending, Header:=xlGuess
   i = 1
   Do While Cells(i, 6) <> ""
     If Cells(i, 6) = Cells(i + 1, 6) Then Rows(i).Delete Else i = i + 1
   Loop
   Application.Calculation = xlCalculationAutomatic
End Sub

Sub SupDoublonsGardeDernier2()
   Dim i
   Dim mondico As Object
   Set mondico = CreateObject("Scripting.Dictionary")
   [f1].Sort Key1:=Range("f2"), Order1:=xlAscending, Header:=xlGuess
   For i = 1 To [f1].End(xlDown).Row
     If Cells(i, 6) <> Cells(i + 1, 6) Then mondico(CStr(Cells(i, 6))) = CStr(Cells(i, 7))
   Next
   [M1].Resize(mondico.Count) = Application.Transpose(mondico.keys)
   [n1].Resize(mondico.Count) = Application.Transpose(mondico.items)
End Sub

JB

 

[Okedekpe]

Re : Rechercher une date et copier une plage de cellules correspondante, sans doublon

Bonjour Pierrot93, Boisgontier, le forum,

Pierrot93, merci pour l'astuce, je ne le savais pas.

Boisgontier, tes codes fonctionnent comme je le souhaite, j'ai encore un peu de mal à tout déchiffrer, surtout le 2e code pour la suppression des doublons, mais à force de F1 et de recherche je pense réussir à m'en sortir.

Une seule question:

Do While Cells(i, 6) <> ""
     If Cells(i, 6) = Cells(i + 1, 6) Then Rows(i).Delete Else i = i + 1
   Loop

Je comprends la boucle qui supprime la ligne si la suivante est la même, par contre que représente le 6? Ce n'est pas sensé être le numéro de colonne?

Il me reste plus qu'à mettre tout ça dans une boucle pour résupérer les données dans mes différents classeurs, je devrai m'en sortir.

Merci beaucoup en tout cas!
Au plaisir de vous lire à nouveau.

Bonne journée.
Amicalement.
Okedekpe

 

[Jacou]

Re : Rechercher une date et copier une plage de cellules correspondante, sans doublon

Bonjour Okedekpe, bonjour le forum,

Code :
Do While Cells(i, 6) <> ""
If Cells(i, 6) = Cells(i + 1, 6) Then Rows(i).Delete Else i = i + 1
Loop



Dans ce code, on supprime la ligne i si la cellule Fi est identique à la cellule F(i+1)

Bonne journée

 

[Okedekpe]

Re : Rechercher une date et copier une plage de cellules correspondante, sans doublon

Re, Jacou,

Bien sur, j'avais complétement zappé que j'avais demandé de coller les cellules en F ...
Donc oui le code n'est pas très complex!

Merci en tout cas!

 

[BOISGONTIER]

Re : Rechercher une date et copier une plage de cellules correspondante, sans doublon

Sub SupDoublonsGardeDernier()
   Dim i
   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual
   Sheets(2).Select
   [f1].Sort Key1:=Range("f2"), Order1:=xlAscending, Header:=xlGuess
   i = 1
   Do While Cells(i, "F") <> ""
     If Cells(i, "F") = Cells(i + 1, "F") Then Rows(i).Delete Else i = i + 1
   Loop
   Application.Calculation = xlCalculationAutomatic
End Sub

Sub SupDoublonsGardeDernier2()
   Dim i
   Dim mondico As Object
   Set mondico = CreateObject("Scripting.Dictionary")
   Sheets(2).Select
   [f1].Sort Key1:=Range("f2"), Order1:=xlAscending, Header:=xlGuess
   For i = 1 To [f1].End(xlDown).Row
     If Cells(i, "F") <> Cells(i + 1, "F") Then mondico(CStr(Cells(i, "F"))) = CStr(Cells(i, "G"))
   Next
   [M1].Resize(mondico.Count) = Application.Transpose(mondico.keys)
   [n1].Resize(mondico.Count) = Application.Transpose(mondico.items)
End Sub

JB

 

[Okedekpe]

Re : Rechercher une date et copier une plage de cellules correspondante, sans doublon

Re,

Merci de prendre le temps de répondre!

Bonne journée.
Okedekpe