Microsoft 365 lien entre tableaux

stef12345

XLDnaute Nouveau
Bonjour,

j'aimerais créer un outil a partir de ce fichier. il faudrait que les noms de la feuille 1 (ici A,B,C...) se notent automatiquement sur la feuille 2 en fonction de leur date de fin inscrite sur la feuille 1.

A , B et C se terminent le 31 juillet 2024 sur la feuille 1 ils s'inscrivent en juillet sur ma feuille 2. je l'ai fait manuellement dans mon fichier mais j'aimerais si c'est possible que ce soit automatisé.

j'espère avoir été suffisamment clair merci de votre aide
 

Pièces jointes

  • Tableau test echéances.xlsx
    30.1 KB · Affichages: 16

chris

XLDnaute Barbatruc
Bonjour

Une proposition PowerQuery

Le nombre d'année du résultat dépend des années des dates de fin.

Il suffit d'actualiser le tableau résultat quand la source change
 

Pièces jointes

  • Tableau_Echéances_PQ.xlsx
    35.9 KB · Affichages: 7
Dernière édition:

job75

XLDnaute Barbatruc
Bonjour stef12345, chris,

Voyez cette macro dans le code de Feuil2 qui utilise le filtre avancé :
VB:
Private Sub Worksheet_Activate()
Dim P As Range, critere As Range, c As Range
Set P = Sheets("Feuil1").[A1].CurrentRegion 'adapter le nom de la feuille
Set critere = P(2, P.Columns.Count + 2)
Application.ScreenUpdating = False
Rows("3:" & Rows.Count).Delete 'RAZ
For Each c In Range("A2", Cells(2, Columns.Count).End(xlToLeft))
    critere = "=AND(G2>=" & c.Value2 & ",G2<EDATE(" & c.Value2 & ", 1))"
    P.AdvancedFilter xlFilterInPlace, critere(0).Resize(2) 'filtre avancé
    P.Columns(1).SpecialCells(xlCellTypeVisible).Copy
    c(2).PasteSpecial xlPasteValues 'collage spécial valeurs
Next
Rows(3).Delete 'supprime les titres copiés
critere = ""
If P.Parent.FilterMode Then P.Parent.ShowAllData 'affiche tout
Application.Goto [A1], True 'cadrage
End Sub
Elle se déclenche quand on active la feuille.

A+
 

Pièces jointes

  • Tableau test echéances.xlsm
    30.5 KB · Affichages: 7

AtTheOne

XLDnaute Accro
Supporter XLD
Bonsoir à toutes & à tous,
Un essai avec des formules matricielles dynamiques, un début de période modifiable (période de 31 mois comme dans l'exemple)
Noms définis : DateDéb , DateFin (date calculée)
Nom du tableau : Liste

Le résultat n'est pas dans un tableau structuré

Formule en A2 (les entêtes) :
VB:
=TEXTE(FIN.MOIS(DateDéb;SEQUENCE(1;DATEDIF(FIN.MOIS(DateDéb;-1)+1;FIN.MOIS(DateFin;0);"M")+1;-1)+1);"mmmm aaaa")
renvoie les 21 entêtes

Formule en A3
VB:
=TRIER(FILTRE(liste[Nom];TEXTE(liste[date rapport];"mmmm aaaa")=A$2;""))
Formule à recopier sous tous les entêtes

Le résultat s'adapte automatiquement aux changements dans le tableau structuré "Liste" et en cas de changement de date de début.

Les formats conditionnels font le reste ...
 

Pièces jointes

  • Tableau test echéances AtTheOne.xlsx
    26.4 KB · Affichages: 4

job75

XLDnaute Barbatruc
Bonjour le forum,

La macro de mon post #3 s'exécute en 0,34 seconde.

Toutes les colonnes du tableau en Feuil2 sont traitées.

On peut gagner du temps en ne traitant que celles dont la date est <= à juin 2025 :
VB:
Private Sub Worksheet_Activate()
Dim P As Range, critere As Range, datemax As Date, c As Range
Set P = Sheets("Feuil1").[A1].CurrentRegion 'adapter le nom de la feuille
Set critere = P(2, P.Columns.Count + 2)
datemax = Application.EoMonth(Application.Max(P.Columns(7)), 0)
Application.ScreenUpdating = False
Rows("3:" & Rows.Count).Delete 'RAZ
For Each c In Range("A2", Cells(2, Columns.Count).End(xlToLeft))
    If c > datemax Then Exit For
    critere = "=AND(G2>=" & c.Value2 & ",G2<EDATE(" & c.Value2 & ", 1))"
    P.AdvancedFilter xlFilterInPlace, critere(0).Resize(2) 'filtre avancé
    P.Columns(1).SpecialCells(xlCellTypeVisible).Copy
    c(2).PasteSpecial xlPasteValues 'collage spécial valeurs
Next
Rows(3).Delete 'supprime les titres copiés
critere = ""
If P.Parent.FilterMode Then P.Parent.ShowAllData 'affiche tout
Application.Goto [A1], True 'cadrage
End Sub
A+
 

Pièces jointes

  • Tableau test echéances.xlsm
    30.7 KB · Affichages: 2

job75

XLDnaute Barbatruc
Bonjour AtTheOne, le forum,

Utilisant des tableaux VBA et le Dictionary ton code est 15 fois plus rapide, c'est normal.

Mais sans être une usine à gaz il est un peu lourd non ?

Chez moi ma macro avec le filtre avancé s'exécute en 0,7 seconde, c'est très acceptable.

A+
 

job75

XLDnaute Barbatruc
Ce qui ne me plait pas ce sont les dates en 2ème ligne de la feuille des résultats, ceci y remédie :
VB:
Private Sub Worksheet_Activate()
Dim P As Range, critere As Range, datemax As Date, datemin As Date, c As Range, dat As Long
Set P = Sheets("BdD").[A1].CurrentRegion 'adapter le nom de la feuille
Set critere = P(2, P.Columns.Count + 2)
datemin = Application.Min(P.Columns(7))
datemax = Application.EoMonth(Application.Max(P.Columns(7)), 0)
Application.ScreenUpdating = False
Rows("3:" & Rows.Count).Delete 'RAZ
Rows(2).ClearContents
For Each c In Range("A1", Cells(1, Columns.Count).End(xlToLeft))
    c = Application.Proper(Format(Application.EDate(datemin, c.Column - 1), "mmmm yyyy")) 'en-têtes
    dat = CDate("1/" & c)
    If dat <= datemax Then
        critere = "=AND(G2>=" & dat & ",G2<EDATE(" & dat & ", 1))"
        P.AdvancedFilter xlFilterInPlace, critere(0).Resize(2) 'filtre avancé
        P.Columns(1).SpecialCells(xlCellTypeVisible).Copy
        c(2).PasteSpecial xlPasteValues 'collage spécial valeurs
    End If
Next
Rows(2).Delete 'supprime les titres copiés
Columns.AutoFit 'ajustement largeurs
critere = ""
If P.Parent.FilterMode Then P.Parent.ShowAllData 'affiche tout
Application.Goto [A1], True 'cadrage
End Sub
 

Pièces jointes

  • Tableau test echéances AtTheOne.xlsm
    97.8 KB · Affichages: 1

job75

XLDnaute Barbatruc
Ceci ne nécessite plus d'intervention de l'utilisateur sur les en-têtes des résultats :
VB:
Private Sub Worksheet_Activate()
Dim P As Range, critere As Range, datemax As Date, datemin As Date, col%, x$, dat As Long
Set P = Sheets("BdD").[A1].CurrentRegion 'adapter le nom de la feuille
Set critere = P(2, P.Columns.Count + 2)
datemin = Application.Min(P.Columns(7))
datemax = Application.EoMonth(Application.Max(P.Columns(7)), 0)
Application.ScreenUpdating = False
Rows("3:" & Rows.Count).Delete 'RAZ
Columns(2).Resize(, Columns.Count - 1).Delete 'RAZ
For col = 1 To 256
    x = Application.Proper(Format(Application.EDate(datemin, col - 1), "mmmm yyyy")) 'en-têtes
    dat = CDate("1/" & x)
    If dat > datemax Then Exit For
    Cells(1, col) = x 'en-tête
    critere = "=AND(G2>=" & dat & ",G2<EDATE(" & dat & ", 1))"
    P.AdvancedFilter xlFilterInPlace, critere(0).Resize(2) 'filtre avancé
    P.Columns(1).SpecialCells(xlCellTypeVisible).Copy
    Cells(2, col).PasteSpecial xlPasteValues 'collage spécial valeurs
Next
Rows(2).Delete 'supprime les titres copiés
Columns.AutoFit 'ajustement largeurs
critere = ""
P.Parent.ShowAllData 'affiche tout
Application.Goto [A1], True 'cadrage
End Sub
 

Pièces jointes

  • Tableau test echéances AtTheOne.xlsm
    97.5 KB · Affichages: 2
Dernière édition:

AtTheOne

XLDnaute Accro
Supporter XLD
Bonjour à toutes & à tous
  • @stef12345 : en pièce jointe un classeur avec les 4 possibilités proposées dans ce fil pour traiter ton problème, merci de faire un retour.

  • @job75 : j'ai mis un timer sur chacune des solutions, chez moi (j'ai un PC de 15 d'âge) la solution par filtres élaborés successifs est plutôt pénalisante.

  • @chris : j'ai essayé d'adapter tes requêtes PQ pour afficher tous les mois entre la date min et la date max comprises (et non par année complète). J'ai un peu galérer (peu familiarisé avec PQ). Du coup c'est un peu plus long à s'exécuter. (ta requête en générant les 12 mois de chaque année est bien plus rapide)
    As tu une solution plus efficace que la mienne pour générer tous les mois compris entre une date de début et une date de fin ?
voir la PJ
A bientôt
 

Pièces jointes

  • Tableau test echéances 4 solutions au choix.xlsm
    132.7 KB · Affichages: 4
Dernière édition:

Statistiques des forums

Discussions
313 283
Messages
2 096 813
Membres
106 752
dernier inscrit
Tahiri1976