XL 2019 Macro : Placement d'un texte dans un tableau : VBA impératif

[limagerit]

Bonjour à tous,

Je cherche un bout de code pour placer un texte long ( en moyenne 50 caractères) dans un tableau selon une condition de date .
L'approche par macro est nécessaire car l'utilisation de formule coupe mon texte.
En effet le texte et long et les cases du calendrier seront petites .

N'ayant aucune connaissance en macro, je ne sais pas par quel bout le prendre.

Ci joint un exemple du fichier fini souhaité.

Merci de votre aide ou de vos précieux conseils.

 

[Dranreb]

Bonjour.
Dans un nouveau module :

Option Explicit

Sub Placement()
   Dim Date0 As Date, TDon(), L&, C&, TRés(-1 To 48, 1 To 50)
   Date0 = Feuil1.[C5].Value - 1
   TDon = Feuil1.[A8].Resize(Feuil1.[A1000000].End(xlUp).Row - 7, 2).Value
   For L = 1 To UBound(TDon)
      C = TDon(L, 2) - Date0: TRés(L, C) = TDon(L, 1): TRés(-1, C) = TDon(L, 1)
      Next L
   Feuil1.[C6].Resize(50, 50).Value = TRés
   End Sub

 

[limagerit]

Grand Merci Dranred , cela marche super ,
par contre j'ai un plantage si je le champs date est vide . une idée pour contourner ce problème ?

 

[patricktoulon]

Bonjour une autre approche complètement opérationnelle

 

[Dranreb]

Ajoutez une instruction On Error Resume Next au début si vous voulez juste empêcher que l'erreur provoque l'arrêt de l'exécution. Si ça ne change rien, vérifier si les options VBA ne prévoient pas un arrêt sur toutes les erreurs, même pourtant gérées.

 

[limagerit]

DranRed ; Patrick , Merci bien c'est absolument magnifique .

Puis je me permettre de complexifier le tableau :

Jusqu'à présent, j'ai une zone jaune de data et un résumé
Je souhaite empiler plusieurs zones jaune et plusieurs résumés ( 15 zones au total) .
cf le fichier fait pour le moment avec 3 zones

Avec possibilité de rajout de ligne dans chaque zone
et le contenus de la zone Jaune , se résumant dans chaque ligne verte intermédiaire.

Cela vous semble jouable ?
Promis je n'ajoute plus rien après.

 

[Dranreb]

Alors essayez comme ça :

Option Explicit

Sub Placement()
   Dim RngDon As Range, Date0 As Date, TDon(), L&, LRésum&, C&, TRés()
   Set RngDon = Feuil1.UsedRange
   TDon = RngDon(2, 1).Resize(RngDon.Rows.Count - 1, 2).Value
   ReDim TRés(1 To UBound(TDon, 1), 1 To RngDon.Columns.Count - 2)
   Date0 = RngDon(1, 3).Value - 1
   For L = 1 To UBound(TDon, 1)
      If IsDate(TDon(L, 2)) Then
         C = TDon(L, 2) - Date0: TRés(L, C) = TDon(L, 1): TRés(LRésum, C) = TDon(L, 1)
      ElseIf Left$(TDon(L, 2), 6) = "Résumé" Then
         LRésum = L: End If
      Next L
   RngDon(2, 3).Resize(UBound(TRés, 1), UBound(TRés, 2)).Value = TRés
   End Sub

 

[patricktoulon]

re
avec ma version
tu fait simplement un find previous sur "b" a partir de la ligne lig et tu prend le row et tu a ta ligne d’entête Résum a chaque fois
et je compile les doublons case du 27/02/2022

 

[limagerit]

Wahouuu , C'est bluffant . Tout les deux vous êtes magique
Tous les tests sont passés sans aucun souci ,
Je ne sais pas comment vous faites pour que cela vous parait logique ,

Puis je encore abuser ? oui je sais j'avais promis de ne rien ajouter ,

J'ai un petit code qui me permet d'ajouter une ligne en auto dans une feuille et je voudrais l'adapter pour le déclencher via un petit bouton + sur chaque secteur.
dans mon fichier ajout il est sur la feuille et je le voudrais dans un module mais dans ce cas j'ai le debuger qui s'ouvre.
Comment puis je changer cela svp ?


Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> Range("A65536").End(xlUp).Address Then Exit Sub
If Target = "" Then Exit Sub
Dim T
Application.ScreenUpdating = False
Application.EnableEvents = False ' pour ne pas se mordre la queue
T = Target.Value 'mémorise la valeur
Rows(2).Copy Target.EntireRow.Resize(2) 'copie la ligne 2 et colle sur 2 lignes
Union(Target.Resize(, 7), Target.Offset(1).EntireRow).ClearContents
Target = T
Application.EnableEvents = True
End Sub


Merci de votre aide

 

[patricktoulon]

re
tu clique quelque part dans un des bloc jaune et tu click sur le bouton ca t'ajoute une a la fin de ce block
terminé

 

[patricktoulon]

et pour une utilisation sans crise Epilepsie
je fige les 5 premiere ligne comme ça quand tu scrolle tu garde lles yeux sur l'entete et les boutons

 

[limagerit]

Merci Merci ,
Je vois que tu penses à tout ,
Je fais la version définitive et je vous la partage avec Plaisir
Oui le jaune va disparaitre pour ne plus saigner des yeux

Merci bien pour cette collaboration du dimanche
Bonne fin de week end