XL 2013 VBA Macro temps d'execution trop lent (Dates + heures en couleurs)

PMG

XLDnaute Junior
Bonjour le forum en espérant que tout le monde va bien!

Je reviens vers vous avec un problème de temps d’exécution de macro.
Je dois remplir des cases de couleurs (12 couleurs en tout) correspondant aux dates d'un tableau structuré.
Je souhaiterai passé par le VBA car avec des MFC et SOMMEPROD ça rame beaucoup trop!
Merci d'avance pour votre disponibilité vos lumières!
PMG

VB:
Sub Couleur()
Dim i As Variant, j As Variant, k As Variant

Application.ScreenUpdating = False

Call Effacer

For k = Range("Tableau1[#ALL]").Rows.Count To 1 Step -1 'Tableau
    For i = 16 To 46 'Dates
        For j = 6 To 57 'Heures
            If Cells(i, 4).Value + Cells(11, j).Value >= Range("Tableau1[Début]").Rows(k).Value And Cells(i, 4).Value + Cells(11, j).Value < Range("Tableau1[Fin]").Rows(k).Value Then
                Cells(i, j).Interior.ColorIndex = Range("Tableau1[Code]").Rows(k).Value
                Cells(i, j).Value = Range("Tableau1[Code1]").Rows(k).Value
                Cells(i, j).Font.ColorIndex = Range("Tableau1[Code]").Rows(k).Value
            End If
Next j, i, k

End Sub
 

Pièces jointes

  • VBA Couleurs et dates.xlsm
    33.4 KB · Affichages: 27
Solution
Bonjour @PMG :), @sylvanu ;),

Pour le FUN :
En prenant le problème à l'envers, on ne fait qu'une seule boucle principale sur le tableau structuré des tâches.

C'est très rapide sur ma bécane. En moyenne 0,005 seconde (testé sur 1000 exécutions - voir la macro TestExcec() ).

La macro de mise en couleur est Colorier() dans le module de Feuil1.

Attention ! Pour la journée du 26 mai 2020, les trois plages se chevauchent. Si les trois couleurs sont différentes pour les trois plages, on arrive à une aberration au niveau coloriage.

J'ai ôté la boucle de la macro Effacer().

Le code:
VB:
Sub Colorier()
Dim ti, t, tDates, KO As Boolean, i&, ligne&, colA&, colB&
   ti = Timer: Application.ScreenUpdating = False
   Effacer
   t =...

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonjour @PMG :)

1/ La case en rouge du tableau ("F13") affiche 8:00h, à la base je pouvais la modifier pour ajuster le planning si la plage horaire totale passe à 9:00h 21:00h.
Donc, je modifie par 9 car 9 * 4 (1/4d'heure).
j'ai ajouté une constante HeurDeb que vous initialiserez à l'heure de début du planning.
Et ajouté une ligne pour initialiser la cellule F13 avec l'heure de début HeurDeb.

Les calculs de ColA et ColB ont été modifiés pour tenir compte de l'heure de début et des limites du planning entre les colonnes F et BE:
VB:
         colA = 6 + 4 * (Format(t(i, 2), "hh") - HeurDeb)
         colA = colA + Int(Format(t(i, 2), "nn") / 15)      ' la colonne de début
         If colA < Cells(1, "f").Column Then colA = Cells(1, "f").Column   ' on limite colA à la colonne F (min)
     
         colB = 6 + 4 * (Format(t(i, 3), "hh") - HeurDeb)
         colB = colB + Int(Format(t(i, 3), "nn") / 15) - 1     ' la colonne de fin
         If colB > Cells(1, "be").Column Then colB = Cells(1, "be").Column   ' on limite colB à la colonne BE (max)




2/ Pour cette partie du code:
If ligne > UBound(t) Then KO = True
ligne = ligne + 15 ' la ligne concernée
Peut on l'effacer, car les données sont créés avec une autre macro et non manuellement comme j'ai omis de le mentionner.
Je ne comprends pas trop la question ?
En tout cas, j'ai supprimé la ligne comprenant KO pour placer le bloc suivant entre un If ... then ... Endif, ce qui donne :
VB:
      If ligne <= UBound(tDates) Then
         ' la date de la tâche a bien été trouvée
         ligne = ligne + 15      ' la ligne concernée
           
         colA = 6 + 4 * (Format(t(i, 2), "hh") - HeurDeb)
         colA = colA + Int(Format(t(i, 2), "nn") / 15)      ' la colonne de début
         If colA < Cells(1, "f").Column Then colA = Cells(1, "f").Column   ' on limite colA à la colonne F (min)
     
         colB = 6 + 4 * (Format(t(i, 3), "hh") - HeurDeb)
         colB = colB + Int(Format(t(i, 3), "nn") / 15) - 1     ' la colonne de fin
         If colB > Cells(1, "be").Column Then colB = Cells(1, "be").Column   ' on limite colB à la colonne BE (max)
       
         If colA <= colB Then
            With Range(Cells(ligne, colA), Cells(ligne, colA)).Resize(, colB - colA + 1)
               .Interior.ColorIndex = t(i, 1)      ' Mise en forme
               .Font.ColorIndex = t(i, 1)
               .Value = t(i, 4)
            End With
         End If
      End If

Concernant la MFC de la zonedu planning D16:BG46 :
  • j'ai supprimé toute les MFC
  • j'ai formaté la zone en "dur"
  • j'ai défini une seule règle de MFC sur la zone enlevant les bordures entre deux semaines
 

Pièces jointes

  • PMG- VBA Couleurs et dates- v3.xlsm
    37.6 KB · Affichages: 13
Dernière édition:

PMG

XLDnaute Junior
Re @mapomme,

Merci beaucoup pour les modifications apportées au code!
J'ai eu quelques soucis de débordement avec la version précédente!

Très pratique la constante "HeurDeb" cela permettra d'ajuster plus précisément la plage d'heures et merci d'avoir limiter la zone à celle du tableau.

Autre petit problème si une tâche s'étale sur 2 jours, le code ne la prends pas en compte.
J’espère ne pas soulever un problème trop lourds à gérer.
(Aparté / Je ne veux vraiment pas abuser de votre temps et suis déjà comblé avec la macro modifiée, je ne pensais pas que ma discussion puisse aller aussi loin! )

Est il possible d'intégrer ces paramètres (si trop compliqué tant pis):

J'ai une feuille de calcul dédié au calculs de début et fin de tâches que @CISCO ma aidé à formuler.
Donc parfois certaines tâches s'étalent sur plusieurs jours.
Une MFC viendra "remplir" ou "effacer" les cases pour les tâches qui chevauchent les weeks-ends.

Exemple:
Tâche 1
Code 1
Début 18/05/20 16:00
Fin 19/05/20 16:00

Début Matin09:00
Fin Matin13:00
Début Après midi14:00
Fin Après midi18:00

Le résultat est bluffant concernant la rapidité, je n'en reviens tjs pas!
Mille merci mapomme!
 

mapomme

XLDnaute Barbatruc
Supporter XLD
Re,

QUOTE="PMG, post: 20335596, member: 277418"]
Est il possible d'intégrer ces paramètres (si trop compliqué tant pis):
[/QUOTE]

D'emblée, ce n'est pas évident. Le raisonnement est entièrement à revoir.
Je ne comprends plus très bien comment fonctionne le tableau de des tâches. Il faudrait un exemple concret.
Pour ne pas reprendre à partir de zéro, je verrai plus une macro intermédiaire décomposant chaque tâche en tâches élémentaires.
Tâche 1 décomposée en tâche 1.1 du matin du jour J, puis une autre ligne avec une tâche 1.2 pour l'après-midi du jour J, puis une tâche 1.3 pour le matin du jour J+1, etc. (j'ai compris qu'il y avait une pause méridienne, non ?)
Bref un fichier représentatif de votre cas serait utile.
 

PMG

XLDnaute Junior
Re,

Merci pour votre réponse.
Effectivement j'ai deux tableaux à remplir.

1/Tableau 1 (temps réel)
Le code de votre dernier fichier est parfait, il correspond exactement à ma demande.
1.1 Les cases sont remplis par mes soins.
1.2 En actualisant, une macro génèrent la couleur, le début et la fin de chaque tâches pour chaque jour vers un tableau filtré. (copie de couleurs vers dates 03_01.xlsm cf:tableau du haut)
1.3 Votre macro me permet d'afficher les tâches enregistrer comme un historique.

2/Tableau 2 (temps théorique) VBA Couleurs et dates MFC .xlsm
C'est exactement le même forme tableau que le n°1. Ce tableau sert à comparer les temps théoriques et réels.
2.1 Les couleurs, début et fin de tâches sont calculées automatiquement.
2.2 Les cases sont remplis par des MFC (sommeprod qui fait ramer la feuille actuellement, car les 2 tableaux sont sur la même feuille et sont "dynamiques" par le biais de boutons (exemple: copie de couleurs vers dates 03_01.xlsm cf:tableau du bas)
2.3 Je cherche une macro qui intègre les paramètres de couleur, début, fin de journée afin de remplir ce tableau.
 

Pièces jointes

  • Copie de Couleurs vers dates 03_01.xlsm
    39 KB · Affichages: 3
  • VBA Couleurs et dates MFC.xlsm
    35.1 KB · Affichages: 5

PMG

XLDnaute Junior
Bonjour, le forum, @mapomme, @sylvanu,

Pour répondre aux contrainte du "Tableau2", correspondant à une succesion de MFC avec sommeprod que j’avais jusqu’à présent, je me suis permis de rajouter plusieurs lignes au fichier de @sylvanu.

MFC:
Code:
SOMMEPROD((Code=45)*($D16+F$11>=Début)*($D16+F$11<Fin)*(F$11>=$BI$4)*(F$11<$BL$4)*(JOURSEM($D16;2)<6))>0

VBA:
VB:
 If Weekday(tablo2(i, 4), vbMonday) < 6 Then     'Boucle des jours inférieur à samedi'
    If tablo2(i, 4) + tablo2(11, j) >= tablo(k, 2) Then     'Date de début'
       If tablo2(i, 4) + tablo2(11, j) < tablo(k, 3) Then     'Date de fin'
          If tablo2(11, j) >= Range("BI6").Value Then     'Heure de début'
             If tablo2(11, j) < Range("BL6").Value Then     'Heure de fin'

Je ne sais pas si c'est très conventionnel de mettre autant de If à la suite, mais ça marche apparemment!
PMG
A+
 

Pièces jointes

  • Copie de VBA Couleurs et dates(V3).xlsm
    34.9 KB · Affichages: 4

Discussions similaires

Réponses
0
Affichages
83
Réponses
23
Affichages
1 K

Statistiques des forums

Discussions
311 725
Messages
2 081 943
Membres
101 849
dernier inscrit
florentMIG