XL 2016 planning horaire hebdomadaire

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

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

Solution
Avec un poil de restructuration =>
Démo_.gif

P.
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:
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
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)
 
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.
 
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.
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

- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
2
Affichages
1 K
Retour