XL 2019 Recherche valeur (Critère date et ID) et copier valeur dans tableau dans la cellule correspondante

[Rabeto]

Bonjour,

J'aimerai faire une recherche de valeur dans la colonne Type en se basant sur 2 critères (ID et Date) et placer les résultats dans la cellule concernée du tableau.

Je vous joint un fichier pour mieux expliquer la demande, mais c'est juste un exemple.

Il se trouve que je pourrai avoir une centaine d'ID avec des dates allant jusqu'à la fin de l'année.

Par macro si possible

merci,

 

[Rabeto]

mais non patty58, il n'y aura pas de critique selon moi

J'ai testé et cela fonctionne bien juste le temps d'exécution mais je penses que c'est aussi la meilleur solution vu que le délai dépend aussi du nombre des cellules que la macro traite,

d'ailleurs j'ai mis votre réponse comme étant la résolution,

 

[Gégé-45550]

Bonjour patty58,

J'ai appliqué le code sur un planning allant jusqu'à fin Décembre 2024 avec une centaine d'ID et ça prend vraiment du temps, est ce normal stp ?

Bonjour,
Essayez ça :

Sub Calendrier()
Dim i%, j%, derlig%, Debut(), Fin(), finCal&, Dates()
Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    derlig = ws.Range("A" & Rows.Count).End(xlUp).Row
    finCal = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column
    ReDim Dates(finCal - 7)
    For i = 8 To finCal
        Dates(i - 8) = Int(CDbl(ws.Cells(2, i).Value))
    Next i
    ReDim Debut(derlig - 2)
    ReDim Fin(derlig - 2)
    For i = 2 To derlig
        Debut(i - 2) = Int(CDbl(ws.Range("C" & i).Value))
        Fin(i - 2) = Int(CDbl(ws.Range("D" & i).Value))
    Next i
    For i = LBound(Debut) To UBound(Debut) - 1
        For j = LBound(Dates) To UBound(Dates) - 1
            If Debut(i) <= Dates(j) And Fin(i) >= Dates(j) Then
                ws.Cells(i + 3, j + 8) = ws.Cells(i + 2, 2)
            End If
        Next j
    Next i
End Sub

Cordialement,

 

[Rabeto]

Bonjour, Gégé-45550 et patty58
merci pour vos réponses,

Gégé-45550 : merci, J'ai essayé le code, mais le résultat donne autre chose quand j'ajoute plus de donnée, dans le ficher avec votre pseudo

patty58 : Une dernière chose svp, (dans le ficher avec votre pseudo) j'ai essayé de modifier votre code en adaptant un peu les valeurs selon le model final du fichier mais je n'y arrive pas

 

[dysorthographie]

Bonjour,

'Ws.Range("A65536").End(xlUp).Row
Ws.cells(rows.count,"A").End(xlUp).Row

Ça fait bien longtemps qu'on est plus en xls mais en xlsx!

@Rabeto ton application doit tourner sur Windows et\ou Mac ?

 

[Rabeto]

Bonjour dysorthographie

C'est sur Windows

 

[Rabeto]

Bonjour dysorthographie

C'est sur Windows

Je veux juste adapter le code dans le fichier Patty58 selon les données dans le fichier

 

[patty58]

Bonjour à tous , Bonjour Rabeto
Si ton fichier est sans cesse modifié, je vais abandonner, je pense.
J'avais commencé à le reprendre pour trouver les colonnes et lignes sans mettre des valeurs fixes, au cas où tu bouleverses encore tout, mais je vois que pour un même ID, tu as encore plusieurs types en fonction des agents.
Donc, pour moi, c'est un gros chantier et il manque du coup des explications.
Je laisse cela à plus fort que moi, je suis trop âgée pour me prendre la tête à ce point sans être sûre, en plus, de te donner satisfaction.
Je suis désolée, j'espère que tu vas trouver quelqu'un de compétent.
Bonne fin de journée

 

[Rabeto]

Bonjour patty58

Je l'ai juste adapté avec le format final dont j'ai besoin,
je pensais que changer quelque valeurs dans tes codes me permets d'avoir ce dont j'ai besoin au final mais j'y ai travaillé sans succès.

mais je vois que pour un même ID, tu as encore plusieurs types en fonction des agents.

ne t'en fait pas pour ces valeurs qui se répètent, ce dont j'ai besoin, c'est juste une MAJ de ton codes selon le dernier model, car tes codes fonctionnent bien.

A moi de rectifier les valeurs répétitifs dans la base.

 

[patty58]

Bonjour
Ecoute, essaie cela, mais c'est long et je ne te promets rien sur les résultats

 

[patty58]

Le fichier n'était pas passé

 

[Dranreb]

Bonjour.
Ceci devrait être un peu plus rapide :

Sub Plani()
   Dim TDon(), RngPlan As Range, DtDéb As Date, DtFin As Date, TPlan(), L As Long, Dt As Date
   TDon = ActiveSheet.[A2].Resize(ActiveSheet.[A1000000].End(xlUp).Row - 1, 4).Value
   Set RngPlan = ActiveSheet.[G3].Resize(UBound(TDon, 1), ActiveSheet.[AN2].End(xlToLeft).Column - 6)
   DtDéb = RngPlan(0, 2).Value
   RngPlan(0, 3).Resize(1, RngPlan.Columns.Count - 2).FormulaR1C1 = "=RC[-1]+1"
   DtFin = RngPlan(0, RngPlan.Columns.Count).Value
   ReDim TPlan(1 To UBound(TDon, 1), 1 To DtFin - DtDéb + 2)
   For L = 1 To UBound(TDon, 1)
      TPlan(L, 1) = TDon(L, 1)
      For Dt = Int(TDon(L, 3)) To Int(TDon(L, 4))
         If Dt > DtFin Then Exit For
         If Dt >= DtDéb Then TPlan(L, Dt - DtDéb + 2) = TDon(L, 2)
         Next Dt, L
   ActiveSheet.[G3].Resize(UBound(TPlan, 1), UBound(TPlan, 2)).Value = TPlan
   End Sub

 

[klin89]

Bonjour à tous

Pour ton problème, tu peux utiliser un dictionnaire pour ventiler tes données.
Pour les récupérer, tu parcours le premier tableau pour former la clé et y associer l'item comme ceci :
Dico(Id & ladate) = "CP"

Ensuite avec la méthode exists du dictionnaire, tu ventiles tes données en parcourant l'autre tableau.

klin89

 

[Dranreb]

J"ai seulement vu après qu'il y avait des doublons sur l'ID. Alors une solution utilisant ma fonction Gigogne.

 

[dysorthographie]

à tester

 

[Rabeto]

Le fichier n'était pas passé

Merci pour ta réponse patty58,

Mais je penses que tu n'as pas envoyé le bon fichier avec la MAJ de ton code, dans module, je me retrouve avec l'ancien code.