XL 2016 Compter Nombre jour Travailé et surligné si superieur à 5

Eric_Clamart

XLDnaute Nouveau
Bonjour
J'ai tableau qui récupére les plannings des employées sur l'année. J'aimerai pouvoir, sur ce tableau, compter tous les jours travaillés consécutif, "JT", et si supérieur à 5 jours, que la plage soit surlignée.
Je n'arrive pas a trouver un code VBA pour cela étant un peu novice .....
En vous remerciant pour votre aide.
 

Pièces jointes

  • Planning Test.xlsx
    16.9 KB · Affichages: 9

Monptipiton

XLDnaute Nouveau
Bonjour,

- Déclarer les variables : i as long, etc
- Créer un array : dim Tablo()
- Désactiver le rafraichissement d'écran : application.screenupdating
- Transférer la plage dans l'array : tablo = range(...)
- Boucler sur l'array et mettre en place un compteur et une condition pour surligner les cellules concernées
- Réactiver le rafraîchissement d'écran
- Libérer la mémoire : erase tablo

Avec ça tu devrais t'en sortir et pouvoir faire ton job

@+
 

Eric_Clamart

XLDnaute Nouveau
Bonjour
Merci pour votre réponse qui répond presque à mes besoins.
Les plus de 5 jours travaillés sont bien surlignés quand ils sont sur la même ligne mais fin octobre début novembre par exemple, la personne a travaillé 8 jours de suite mais ils ne sont pas surlignés en rouge.
De plus ayant 40 employés, est il possible de faire appel à un dialog box pour déterminer la range ?
Merci encore
 

fanfan38

XLDnaute Barbatruc
Bonsoir
Le problème est réglé...
Pour les 40 employés je présume que ça c'est la feuille d'un employé?
il faut choisir la feuille en fonction du choix de l'employé?
A+ François
 

Pièces jointes

  • Planning Test.xlsm
    30.4 KB · Affichages: 5

fanfan38

XLDnaute Barbatruc
Tu as raison la macro peux prendre toute la feuille...
A ajouter en debut de macro (apres le sub
Application.ScreenUpdating = False
et en fin de macro avant le end sub
Application.ScreenUpdating = true

A+ François
 

Pièces jointes

  • Planning Test- surligner plus de 6 jours.xlsm
    36.1 KB · Affichages: 7
Dernière édition:

fanfan38

XLDnaute Barbatruc
VB:
Private Sub CommandButton1_Click() 'contrôle
 Application.ScreenUpdating = False 'gain de temps pas d'affichage
 'declaration des variables'
  Dim i As Long, col As Integer, nb As Byte, j As Integer, derlig As Long
  'initialisation de la variable nombre'
   nb = 0
   'recherche de la dernière ligne de la feuille'
   derlig = Range("A" & Rows.Count).End(xlUp).Row
   'boucle de la ligne 4 à la dernière ligne'
   For i = 4 To derlig
   'si la cellule de la 1ère colonne n'est pas vide
    If Len(Range("A" & i).Value) > 0 Then
    'boucle de la colonne 2 à 32'
     For col = 2 To 32
     'si la cellule est = à JT
      If Cells(i, col).Value = "JT" Then
        nb = nb + 1 'nombre =nombre +1
        'colorie la cellule en jaune
        Cells(i, col).Interior.ColorIndex = 6
      Else 'sinon'
       nb = 0 'reinitialise le nombre
       'colorie les cellules en fonction de leur contenu
       Select Case UCase(Cells(i, col).Value)
         Case Is = "JRS"
          Cells(i, col).Interior.ColorIndex = 17
         Case Is = "CP"
          Cells(i, col).Interior.ColorIndex = 4
         Case Is = "EF"
          Cells(i, col).Interior.ColorIndex = 8
         Case Is = "DEP"
          Cells(i, col).Interior.ColorIndex = 7
         Case Is = "CFA"
          Cells(i, col).Interior.ColorIndex = 22
         Case Is = "N/A" 'efface les cellules contenant N/A'
          Cells(i, col).ClearContents
       End Select
      End If
      If nb > 5 Then 'si nombre >5'
       If col + 1 - nb > 2 Then 'si c'est sur la même ligne
        Range(Cells(i, col + 1 - nb), Cells(i, col)).Interior.ColorIndex = 3
       Else 'sinon recherche de la dernière cellule de la ligne précédente'
        j = 32
        While Cells(i - 1, j).Value <> "JT"
                  j = j - 1
        Wend 'colorie la ligne précédente'
        Range(Cells(i - 1, j - nb + col), Cells(i - 1, j)).Interior.ColorIndex = 3
        'et la ligne suivante'
        Range(Cells(i, 2), Cells(i, col)).Interior.ColorIndex = 3
       End If
      End If
     Next
    Else
      nb = 0
    End If
   Next
    Application.ScreenUpdating = True 'remet l'affichage

A+ François
 

Statistiques des forums

Discussions
311 733
Messages
2 082 015
Membres
101 867
dernier inscrit
XFPRO