XL 2016 planning horaire hebdomadaire

halecs93

halecs93

XLDnaute Impliqué
Bonjour,

En suivant pas mal de conseils, j'ai créé un tableau me permettant d'organiser une semaine de travail pour plusieurs personnes. Cependant, j'aimerais pouvoir entrer les heures simplement en cliquant-glissant sur des cellules (feuille ''amplitude'') de façon à ne pas saisir manuellement les infos sur la feuille ''planning''. Cela me semblerait plus ergonomique.

Un grand merci
 

Pièces jointes

  • PLANNING HEBDO - AMPLITUDE HORAIRE - excel downloads.xlsx
    211.2 KB · Affichages: 22
Solution
p56
Avec un poil de restructuration =>
Démo_.gif

P.
Trier par date Trier par votes
p56

p56

XLDnaute Occasionnel
Bonjour,
Alors d'abord basique, pour colorer une sélection quelconque de cellules à la souris, dans le code de la feuille concernée, un code du genre :
VB: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Integer

    For i = 0 To Target.Columns.Count - 1
        Me.Cells(Target.Row, Target.Column + i).Interior.Color = &HFF
    Next i
End Sub

Ensuite, s'il faut limiter sur une seule ligne avec plus d'une colonne, le code devient :
Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Integer

    If Target.Rows.Count = 1 And Target.Columns.Count > 1 Then
        For i = 0 To Target.Columns.Count - 1
            Me.Cells(Target.Row, Target.Column + i).Interior.Color = &HFF
        Next i
    End If
End Sub

Et encore ensuite, s'il faut limiter sur une ou plusieurs zones particulières le code est alors :
Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Integer, Zn As Range

    Set Zn = Union(Me.Range("S3:BS8"), Me.Range("S11:BS16"))
    If Not Intersect(Target, Zn) Is Nothing And Target.Rows.Count = 1 And Target.Columns.Count > 1 Then
        For i = 0 To Target.Columns.Count - 1
            Me.Cells(Target.Row, Target.Column + i).Interior.Color = &HFF
        Next i
    End If
End Sub

Et on peut aussi prévoir un droit à modifier, pour inverser la couleur, avec ce code :
VB: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Integer, Zn As Range

    Set Zn = Union(Me.Range("S3:BS8"), Me.Range("S11:BS16"))
    If Not Intersect(Target, Zn) Is Nothing And Target.Rows.Count = 1 And Target.Columns.Count > 1 Then
        For i = 0 To Target.Columns.Count - 1
            Me.Cells(Target.Row, Target.Column + i).Interior.Color = _
                IIf(Me.Cells(Target.Row, Target.Column + i).Interior.Color = &HFF, &HFFFFFF, &HFF)
        Next i
    End If
End Sub

Autre façon d'écrire pour le même effet :
VB: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Zn As Range, Cel As Range

    Set Zn = Union(Me.Range("S3:BS8"), Me.Range("S11:BS16"))
    If Not Intersect(Target, Zn) Is Nothing And Target.Rows.Count = 1 And Target.Columns.Count > 1 Then
        For Each Cel In Range(Target.Address)
            Cel.Interior.Color = IIf(Cel.Interior.Color = &HFF, &HFFFFFF, &HFF)
        Next Cel
    End If
End Sub

Nb : avec ces codes, les MFC sont à supprimer

Ensuite s'il faut enregistrer quelque part les info saisies à la souris, on peut aussi proposer du code.
P
 
Dernière édition:
Vote positif 0 Vote négatif
halecs93

halecs93

XLDnaute Impliqué
p56 à dit:
Bonjour,
Alors d'abord basique, pour colorer une sélection quelconque de cellules à la souris, dans le code de la feuille concernée, un code du genre :
VB: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Integer

    For i = 0 To Target.Columns.Count - 1
        Me.Cells(Target.Row, Target.Column + i).Interior.Color = &HFF
    Next i
End Sub

Ensuite, s'il faut limiter sur une seule ligne avec plus d'une colonne, le code devient :
Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Integer

    If Target.Rows.Count = 1 And Target.Columns.Count > 1 Then
        For i = 0 To Target.Columns.Count - 1
            Me.Cells(Target.Row, Target.Column + i).Interior.Color = &HFF
        Next i
    End If
End Sub

Et encore ensuite, s'il faut limiter sur une ou plusieurs zones particulières le code est alors :
Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Integer, Zn As Range

    Set Zn = Union(Me.Range("S3:BS8"), Me.Range("S11:BS16"))
    If Not Intersect(Target, Zn) Is Nothing And Target.Rows.Count = 1 And Target.Columns.Count > 1 Then
        For i = 0 To Target.Columns.Count - 1
            Me.Cells(Target.Row, Target.Column + i).Interior.Color = &HFF
        Next i
    End If
End Sub

Et on peut aussi prévoir un droit à modifier, pour inverser la couleur, avec ce code :
VB: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Integer, Zn As Range

    Set Zn = Union(Me.Range("S3:BS8"), Me.Range("S11:BS16"))
    If Not Intersect(Target, Zn) Is Nothing And Target.Rows.Count = 1 And Target.Columns.Count > 1 Then
        For i = 0 To Target.Columns.Count - 1
            Me.Cells(Target.Row, Target.Column + i).Interior.Color = _
                IIf(Me.Cells(Target.Row, Target.Column + i).Interior.Color = &HFF, &HFFFFFF, &HFF)
        Next i
    End If
End Sub

Autre façon d'écrire pour le même effet :
VB: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Zn As Range, Cel As Range

    Set Zn = Union(Me.Range("S3:BS8"), Me.Range("S11:BS16"))
    If Not Intersect(Target, Zn) Is Nothing And Target.Rows.Count = 1 And Target.Columns.Count > 1 Then
        For Each Cel In Range(Target.Address)
            Cel.Interior.Color = IIf(Cel.Interior.Color = &HFF, &HFFFFFF, &HFF)
        Next Cel
    End If
End Sub

Nb : avec ces codes, les MFC sont à supprimer

Ensuite s'il faut enregistrer quelque part les info saisies à la souris, on peut aussi proposer du code.
P
Cliquez pour agrandir...
Merci pour ces précieuses infos.

En effet, le but serait de récupérer ensuite les infos (en gros, les traduire en périodes/tranches horaires)
 
Vote positif 0 Vote négatif
p56

p56

XLDnaute Occasionnel
Re,

Alors pour votre fichier c'est simple. On garde la MFC et le code devient un truc genre :
VB: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Zn As Range, i As Integer, Cl As Integer

    Set Zn = Union(Me.Range("S3:BS8"), Me.Range("S11:BS16")) 'etc ...
    If Not Intersect(Target, Zn) Is Nothing And Target.Rows.Count = 1 And Target.Columns.Count > 1 Then
        With Sheets("Planning")
            Cl = .Cells(Target.Row, "B").End(xlToRight).Column + 1
            .Cells(Target.Row, Cl).Value = Me.Cells(2, Target.Column).Value
            .Cells(Target.Row, Cl + 1).Value = Me.Cells(2, Target.Column + Target.Columns.Count - 1).Value
        End With
    End If
End Sub
Ceci dit, juste une remarque, pourquoi faire en double ce planning? Ça alourdit inutilement votre fichier.
Amha,il serait plus simple de mettre les données dans une feuille et le planning visuel sur une autre sans doublon. Mais bon...
P.
 
Vote positif 0 Vote négatif
halecs93

halecs93

XLDnaute Impliqué
p56 à dit:
Re,

Alors pour votre fichier c'est simple. On garde la MFC et le code devient un truc genre :
VB: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Zn As Range, i As Integer, Cl As Integer

    Set Zn = Union(Me.Range("S3:BS8"), Me.Range("S11:BS16")) 'etc ...
    If Not Intersect(Target, Zn) Is Nothing And Target.Rows.Count = 1 And Target.Columns.Count > 1 Then
        With Sheets("Planning")
            Cl = .Cells(Target.Row, "B").End(xlToRight).Column + 1
            .Cells(Target.Row, Cl).Value = Me.Cells(2, Target.Column).Value
            .Cells(Target.Row, Cl + 1).Value = Me.Cells(2, Target.Column + Target.Columns.Count - 1).Value
        End With
    End If
End Sub
Ceci dit, juste une remarque, pourquoi faire en double ce planning? Ça alourdit inutilement votre fichier.
Amha,il serait plus simple de mettre les données dans une feuille et le planning visuel sur une autre sans doublon. Mais bon...
P.
Cliquez pour agrandir...
Bonjour et merci.

J'ai intégré votre code...et il semble ne pas permettre plus d'une plage horaire par jour. En effet, j'en créé une le lundi par exemple et lorsque je veux en ajouter une autre sur ce même jour, la première s'efface...je n'en comprends pas la raison (je remets le fichier modifier en téléchargement).
 

Pièces jointes

  • PLANNING HEBDO - AMPLITUDE HORAIRE - excel downloads.xlsm
    217.8 KB · Affichages: 10
Vote positif 0 Vote négatif

Discussions similaires

T
  • Résolu(e)
XL 2019 Planning hebdomadaire de réservation de salle
Réponses
14
Affichages
377
telemarrk
T
halecs93
  • Résolu(e)
XL 2016 Copie transposée de planning
2
Réponses
24
Affichages
895
job75
job75
N
  • Résolu(e)
Microsoft 365 Rechercher la dernière cellule saisie dans un TS et ajouter l'heure système
17 18 19
Réponses
277
Affichages
65 K
NONO14
N
A
  • Question
Microsoft 365 Fichier de statistique et roulement
Réponses
0
Affichages
380
Aurel’Byylieve
A
Z
  • Question
Microsoft 365 planning nettoyage
Réponses
5
Affichages
618
Wayki
Wayki
B
  • Question
XL 2016 Formule avec plusieurs conditions pour planning heures annuelles
Réponses
5
Affichages
549
fanfan38
fanfan38
L
  • Question
Microsoft 365 Planning pour gestion de chantiers annuel mensuel et hebdomadaire
Réponses
3
Affichages
2 K
lolo_excelbeginner
L
M
  • Résolu(e)
XL pour MAC Fonction peut s'adapter au changement de ligne ?
Réponses
4
Affichages
518
MaiBZH
M
D
  • Question
XL 2019 Mon classeur a explosé ( énorme projet macro détruit par le "Partage de classeur" )
Réponses
2
Affichages
412
Staple1600
Staple1600
D
  • Question
XL 2019 Planning affichage hebdomadaire commence à lundi pour finir à dimanche
Réponses
6
Affichages
2 K
JHA
J

Membres actuellement en ligne

Aucun membre en ligne actuellement.
2 membres et 92 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 708
Messages
2 112 090
Membres
111 416
dernier inscrit
philipperoy83