[VBA] amélioration tableau mémoire

Question

A mon petit niveau, j'arrive maintenant à peu près à me débrouiller avec les tableaux en mémoire, grâce aux aides et astuces de Pijaku, h2so4, LouReed, Eriiic, etc. Je vous remercie encore une fois infiniment, c'est génial. Je suis du coup arrivé à pondre le petit code imparfait ci-dessous. Il permet de créer le planning de certaines personnes, à partir d'une base de données (feuil8), dans laquelle on a des 1 ou du vide, dans les colonnes LUNDI, MARDI ... DIMANCHE. Il ne génère rien si le jour est férié. C'est pas grand chose, mais j'en suis déjà content. Mon souci, c'est que si une personne est hospitalisée, il ne faudrait pas lui générer de croix. On sait qu'une personne est hospitalisée si une date est rentrée dans la colonne hospitalisation (on notera la date de début d'indisponibilité de la personne). Je n'arrive pas, dans la logique, à inclure ceci. Pareil, il faudrait que si la date de début de service de la personne se trouve un mois ultérieur à celui qu'on veut créer, alors on zappe la personne. Ca me paraît intégrable au 'si OK ou hospitalisation', mais je pense que pour résoudre le problème, il devrait sauter. Le bouton "nouveau mois" est actif, c'est celui qui lance la macro. Sub créerMois() Dim ladate As String, ShNew As String Dim jour As String ladate = Format(Year(Date) & "/" & Month(Date) + 1 & "/" & 1, "dd/mm/yyyy") 'on propose le 1er jour du mois suivant ladate = InputBox("Date du 1er jour du mois à créer ?", "Création", ladate) If IsDate(ladate) = False Then Exit Sub 'si mauvaise date rentrée, on quitte &#91;D5&#93; = CDbl(CDate(ladate)) 'on écrit le date en D5, le reste du mois s'adapte ShNew = Format(ladate, "mmmm") 'on récupère le mois en toutes lettres pour nommer la feuille qu'on va créer ActiveSheet.Copy after:=ActiveSheet: ActiveSheet.Name = ShNew 'on copie la feuille et on la nomme avec notre variable ActiveSheet.Shapes.Range(Array("Rectangle : coins arrondis 2")).Delete 'on supprime la forme de création de mois Dim tablo() Dim j As Integer j = 0 With Feuil8.ListObjects("T_BDD").ListColumns("DÉBUT DU SERVICE").Range.Cells(1, 1) 'la référence est la cellule "Début de service, BD feuil8 For i = 1 To Feuil8.Range("T_BDD").Rows.Count 'on boucle de 1 au nombre total de lignes de la BDD 'si la cellule "SITUATION" de la ligne concernée est égale à "OK" ou "Hospitaliation" If UCase(.Offset(i, 11).Value) = "OK" Or UCase(.Offset(i, 11).Value) = "HOSPITALISATION" Then j = j + 1 'on incrémente J ReDim Preserve tablo(1 To 157, 1 To j) tablo(1, j) = .Offset(i, -10) '1ère valeur = numéro tablo(2, j) = .Offset(i, -8) '2ème valeur = nom tablo(3, j) = .Offset(i, -2) '3ème valeur = régime For k = 4 To 157 Step 5 'on n'aura pas forcément de 4ème valeur, ou 5ème, etc. Donc variable qui va adapter. 'si D5 est une date, et n'est pas un jour férié, alors If IsDate(Sheets(ShNew).Range("A5").Offset(0, k - 1)) And _ Not (IsNumeric(Application.Match(Sheets(ShNew).Range("A5").Offset(0, k - 1), Feuil8.Range("AB1:AB200"), 0))) Then jour = UCase(Format(Sheets(ShNew).Range("A5").Offset(0, k - 1), "dddd")) 'on récupère le jour de la date en toutes lettres If Feuil8.ListObjects("T_BDD").ListColumns(jour).Range.Cells(i + 1, 1) = 1 Then 'si la cellule ligne actuelle, dans la colonne nommée comme le jour est égale à 1 tablo(k, j) = "X" 'la ligne k du tableau est égale à "X" If .Offset(i, 8) = 1 Then tablo(k + 1, j) = "X" 'si la valeur "pain" est égale à 1, k+1 = "X" If .Offset(i, 9) = 1 Then tablo(k + 2, j) = "X" 'si la valeur "potage" est égale à 1, k+2 = "X" If .Offset(i, 10) = 1 Then tablo(k + 3, j) = "X" 'si la valeur "soir" est égale à 1, k+3 = "X" Else: End If Else: End If Next k 'une fois tous les tests effectués pour une date, on passe 5 colonnes à droite, donc au lendemain Else: End If Next i 'une fois tous les jours du mois passés, on passe à la personne suivante et on recommence End With Sheets(ShNew).Cells(7, 1).Resize(UBound(tablo, 2), UBound(tablo, 1)) = Application.Transpose(tablo) 'on colle tout ça au bon endroit. End Sub Merci beaucoup à vous, si certains veulent passer du temps pour m'aider à améliorer ceci ...

galopin01 · Accepted Answer

Finalement ça m'a empêché de dormir, je t'ai finalisé TOUT sauf ton "Hospitalisation" qui me parait un peu confus.

Mais je t'ai laissé un ligne pour te montrer ou ajouter une condition...

Hum... J'ai testé un minimum mais ça devrait être bon !

22exemple-algo-vg2.xlsm (143.58 Ko)

A+

curulis57 · Answer

Premières choses avant de continuer le décorticage... - vérifier que la feuille ne soit pas déjà créée ; - le nom de la forme "Rectangle" copiée sera toujours '1', me semble-t-il, et sera à chrcher dans la feuille du nom "ShNew". ShNew = Format(ladate, "mmmm") 'on récupère le mois en toutes lettres pour nommer la feuille qu'on va créer For x = 1 To Sheets.Count If Sheets(x).Name = ShNew Then _ MsgBox "Ce mois a déjà été créé !": _ Exit Sub Next ActiveSheet.Copy after:=ActiveSheet: ActiveSheet.Name = ShNew 'on copie la feuille et on la nomme avec notre variable Worksheets(ShNew).Shapes.Range(Array("Rectangle : coins arrondis 1")).Delete 'on supprime la forme de création de mois Avant de me casser la tête à comprendre : - comment définis-tu le menu précis de chaque personne ? Déso, parlé trop vite... - valeurs "Livrée", "Livré",... ?? Différences ? Utilité ? Entrée manuelle ? A+...

galopin01 · Answer

Chez moi (2016) ces shapes ne sont pas copiées et provoquent une erreur si on essaie de les supprimer. Ça me parait pas net cette histoire de OK et d'hospitalisation... Il me semble que si OK on livre mais pas si "hospitalisation"... A quoi doit-on se fier : A la colonne V ou à la colonne X... pourquoi faire 2 colonnes ? Ça augmente le risque que les 2 colonnes ne concordent pas... A+...

galopin01 · Answer

Moi je te le donne comme je le comprend et sans ton charabia d'Offset pour cause d'incompréhension. De plus je n'ai gardé que la condition sur la date de départ et "OK" parce que tes explications sur les hospitalisation, pour moi c'est du jus de boudin. Eventuellement YAPUKA rajouter des condition à Y...Tu verras c'est intuitif ! Il suffit que chaque ligne de Y soit Vrai : Quand les idées sont claires les mots pour le dire se trouvent aisément... Je n'ai rempli que les 3 premières colonnes pour cause d'allergies aux complications : Tous le reste des adresses doit être écrit "en dur" comme ces 3 premières colonnes. On ne fait référence qu'au tableau source et au tableau cible : Ça se lit comme la feuille... C'est quand même plus simple que de calculer des décalages... A+...

galopin01 · Answer

Je viens de réfrléchir que pour évaluer la date, étant donné que ArrC n'intègrent pas laDate, tu auras besoin de te faire une petite Fonction perso qui évaluera en fonction de "k" et de "laDate" si "leJour" est un dimanche ou un Férié...

Je n'ai pas envie de travailler la dessus maintenant : Galopin est un couche tôt... Mais demain j'essaierai de te bricoler une "tite" fonction simple à partir de ces param... pour que tu puisses ajuster ton remplissage...

A+

curulis57 · Answer

Salut JoyeuxNoël,
Salut Galopin (bonne nuit ! ),

- à l'ouverture du fichier, une macro décide de l'affichage "Hospitalisation" si une date en [X:X] arrive à échéance ;

Private Sub Workbook_Open()
'
With Worksheets("Noms & Coordonnées")
    For x = 2 To .Range("X" & Rows.Count).End(xlUp).Row
        If .Range("X" & x).Value <> "" Then _
            If IsDate(.Range("X" & x).Value) Then _
                If CDate(.Range("X" & x).Value) <= Date Then .Range("V" & x).Value = "Hospitalisation"
    Next
End With
'
End Sub

- petite gestion des données de l'InputBox (ne t'étonne pas, je me sers souvent des mêmes variables pour plusieurs choses tant qu'elles ne s'entrechoquent pas, bien sûr)

Do
    iOK = 1
    ShNew = Application.InputBox("Date du 1er jour du mois à créer ?", "Création", Default:=Format(dDate, "[$-040C]dd/mm/yyyy"), Type:=2)
    If IsDate(ShNew) Then
        If Day(CDate(ShNew)) = 1 Then
            iOK = 0
            For x = 1 To Sheets.Count
                If Sheets(x).Name = WorksheetFunction.Proper(Format(CDate(ShNew), "mmmm")) Then _
                    MsgBox "Ce mois a déjà été créé !": _
                    iOK = 1
            Next
        End If
    End If
Loop Until iOK = 0 Or ShNew = "Faux"
If ShNew = "Faux" Then Exit Sub

- calcul principal

tBDD = Range("T_BDD").Value
iOK = WorksheetFunction.CountIf(Range("T_BDD[STATUT]"), "OK") + WorksheetFunction.CountIf(Range("T_BDD[STATUT]"), "Hospitalisation")
With Worksheets(ShNew)
    tExtract = .Range("A7:FB" & 6 + iOK).Value
    For x = 1 To UBound(tBDD, 1)
        iOK = 0
        If tBDD(x, 22) = "OK" Or tBDD(x, 22) = "Hospitalisation" Then
            iIdx = iIdx + 1
            tExtract(iIdx, 1) = tBDD(x, 1)
            tExtract(iIdx, 2) = tBDD(x, 3)
            tExtract(iIdx, 3) = tBDD(x, 9)
            For y = 1 To Day(DateAdd("m", 1, dDate) - 1)
                dToday = DateAdd("d", iOK, dDate)
                If CDate(tBDD(x, 11)) <= dToday And Not IsNumeric(Application.Match(dToday, sWkNC.Range("AB1:AB" & sWkNC.Range("AB" & Rows.Count).End(xlUp).Row), 0)) Then
                    If (tBDD(x, 22) = "Hospitalisation" And dToday < CDate(tBDD(x, 24))) Or tBDD(x, 22) = "OK" Then
                        If CInt(tBDD(x, 11 + Weekday(dToday, vbMonday))) = 1 Then
                            tExtract(iIdx, 3 + (iOK * 5) + 1) = "X"
                            For Z = 19 To 21
                                If CInt(tBDD(x, Z)) = 1 Then tExtract(iIdx, 3 + (iOK * 5) + (Z - 17)) = "X"
                            Next
                        End If
                    End If
                End If
                iOK = iOK + 1
            Next
        End If
    Next
    .Range("A7").Resize(iIdx, UBound(tExtract, 2)).Value = tExtract
End With

À adapter en fonction de la disposition de tes données secondaires (statuts, fériés) dans ton fichier final.

12exemple-algo.xlsm (140.78 Ko)

A+

galopin01 · Answer

La modif pour une date d'hospitalisation colonne 24 (le jour d'hospitalisation est livré, à partir du lendemain non) : 'Ensuite il faudra rajouter une conditions pour les autres exceptions... (Hospitalisation etc...) Y1 = Y1 And Not (ArrS(i, 24) &lt;&gt; "" And ArrS(i, 24) &lt; CDate(DateSerial(Year(laDate), Month(laDate), (k + 1) / 5))) If Y1 Then 'Gère les exceptions -La suite sans changement. A+...

curulis57 · Answer

Petit défaut de signalisation : j"aurais dû laisser "Hospitalisation" pour cette personne, cela fonctionnera. C'est un aspect, pas trop difficile mais, comme le soulignait Galopin, à mettre au point. Qui dit "Hospitalisation" ou "Arrêt" dit "Reprise". Je te propose ceci en colonne &#91;X:X&#93; : - pour une future H ospitalisation : " H /12-2-2021" ; - pour un futur A rrêt (vacances, retour en famille... ??) : " A /15-3-2021" ; - non, je ne te dirai pas pour un futur décès ! - pour une date de reprise après "Hospitalisation" ou "Arrêt" : " R /25-4-2021 Il faut également savoir comment tu vas archiver tes feuilles car il faut trouver ces infos de mois en mois pour connaître les dates "Hospitalisation" et "Arrêt" à maintenir. Si ça te convient, je planche là-dessus... A+...

galopin01 · Answer

Ce qui est intéressant : Hormis la phase de création de feuille, c'est l'absence totale de référence à ces feuilles. On pompe toutes les données dans un Array Source (ArrS) et on prépare un Array Cible (ArrC) vide qui a déjà sa dimension définitive. Ce qui évite les nombreux Redim (chronophages et surtout incompréhensibles car transposés.

Ainsi on travaille toujours en mémoire avec des indices faciles à lire (Ça se lit comme les Cells des Tableaux d'origine) Pas besoin de décodeur pour savoir de quoi on parle !

Toujours dans le même esprit on sous-traite l'identification des routines (Jours Fériés…) à une fonction perso…

Les conditions sont facilement lisible grâce à la structure :

Y = Cond1

Y = Y And Cond2 'ou Or….

J'aurai encore pu ajouter un ou 2 petits allègements mébon… Je trouve cette soluce assez élégante et surtout très lisible. Pas besoin de kilos de commentaires pour comprendre chaque ligne !

A+

curulis57 · Answer

Quelques évolutions : - j'ai supprimé les listes de validation en 'Noms & Coordonnées' &#91;V:V&#93; pour laisser le soin du statut à une macro en fonction de l'encodage en &#91;X:X&#93; ; - en &#91;X:X&#93; donc, tu peux encoder une future date d'hospitalisation ou d'arrêt de livraison temporaires (ou définitives, d'ailleurs) ou une date de décès ; - le principe : une lettre, un "+" et une dat Private Sub Worksheet_Change(ByVal Target As Range) ' Application.EnableEvents = False ' If Not Intersect(Target, Columns("X")) Is Nothing Then iRow = Target.Row If Target = "" Or InStr(Target, "+") = 0 Then Range("V" & iRow).Value = "OK" Target = "" Else sItem = Split(Target, "+")(0) Range("V" & iRow).Value = Switch(sItem = "H" Or sItem = "", "Hospitalisation", sItem = "A", "Arrêt", sItem = "D", "Décès", sItem = "R", "Reprise") End If End If ' Application.EnableEvents = True ' End Sub * H+12-02-2021 = Hospitalisation à partir du 12/02/2021 ; * A+25/03/2021 = arrêt de livraison à partir du 25/03/2021 ; * D+15-02-2021 = décès le 15/02/2021 ; * R+27/02/2021 = reprise après hospitalisation ou arrêt temporaire ; - en fonction du mode d'encodage de la date, tu comprends pourquoi j'ai choisis le '+' comme séparateur et non le slash "/"... Comme ces événements (hospitalisation, arrêt, décès ou reprise) peuvent intervenir de façon inopinée, tu peux intervenir sur ton agenda même si celui-ci est déjà programmé. Il te suffit de sélectionner, sur une feuille-agenda (Février, Mars...) la ligne de la personne concernée sur le nombre de jours souhaités. La sélection doit envelopper des groupes complets de 5 cellules (Repas-Pain-Potage-Soir-Tournée). - s'il y a une seule croix dans la sélection, la macro décide de tout annuler ; - s'il n'y en a aucune, la macro supposera qu'il faut réinstaller les "X" adéquats. Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) ' Dim dDate As Date, iRow%, iRowT%, iCol% ' Application.ScreenUpdating = False ' If Sh.Name &lt;&gt; "Matrice" And Sh.Name &lt;&gt; "Noms & Coordonnées" Then If Selection.Column Mod 5 = 4 And Selection.Columns.Count Mod 5 = 0 Then If WorksheetFunction.CountIf(Selection, "X") &gt; 0 Then Selection.Value = "" Else iRow = Selection.Row With Worksheets("Noms & Coordonnées") iRowT = .Columns(3).Find(what:=Sh.Range("B" & iRow).Value, lookat:=xlWhole, LookIn:=xlValues).Row For x = 0 To (Selection.Columns.Count / 5) - 1 dDate = DateAdd("d", x, CDate(Sh.Cells(5, Target.Column))) If Not IsNumeric(Application.Match(dDate, .Range("AB1:AB" & .Range("AB" & Rows.Count).End(xlUp).Row), 0)) Then iCol = Selection.Column + (x * 5) If CInt(.Cells(iRowT, 11 + Weekday(dDate, vbMonday))) = 1 Then For y = 18 To 21 If y = 18 Or (y &gt; 18 And CInt(.Cells(iRowT, y)) = 1) Then Sh.Cells(iRow, iCol + (y - 18)) = "X" Next End If End If Next End With End If End If Sh.Range("C" & Selection.Row).Select End If ' Application.ScreenUpdating = True ' End Sub ATTENTION : tu restes responsable de l'actualisation de l'affichage en &#91;X:X&#93; pour les mois suivants ces manipulations... Á tester en profondeur... ce que je ferai aussi de mon côté plus tard... A+...