Commentaire dans planning

Le 07/04/2017 à 10:49

Bonjour à tous, j'ai un petit soucis, voici le problème:

J'ai un tableau: sheets("Planning") range("E9:AW" & DerniereLigne)

De "E7" à "AW7" il y a des DATES variables

De "D9" à "D & DerniereLigne" il y a des NOMS

Ce que j'essaie de faire c'est que:

1. Lorsque je rentre un commentaire dans le tableau, les valeurs NOM-DATE et le commentaire se copient sur la feuille "Commentaire" à la dernière ligne

2.Lorsque la date en ("E7") change, les commentaires du tableau s'effacent et se rechargent via la feuille "Commentaire"

Merci.

27mon-planning-copie.xlsm (156.30 Ko)
Le 07/04/2017 à 19:03

Bonjour,

s'il y a un commentaire en cellule E9 et celui-ci a été archivé sur la feuille "Commentaire", à la date 1 par exemple,

si la date de E9 change pour (2) est-ce que le commentaire est remit à date 2 ?

Le 07/04/2017 à 19:28

Bonjour SabV,

Je n'ai pas tout compris à ta question, le commentaire doit appartenir à un nom et une date, quand la date change, à chaque croisement de ce même nom et de cette date le commentaire doit apparaître. Merci

Le 08/04/2017 à 02:58

quand la date change, à chaque croisement de ce même nom et de cette date le commentaire doit apparaître

par exemple on ouvre le fichier

cellule E7 = 1

cellule E4 = mars17

je met un commentaire en E9 vis-à-vis Mr DUPOND Jean

ce commentaire est copier su la feuille "commentaire"

A2 = Mr DUPOND Jean

B2 = 1 mars 2017

C2 = le commentaire

puis je reviens sur la feuille planning et j'appuis sur le bouton "Triangleisocèle12_Cliquer"

action - tous les commentaires de la feuille "planning" sont effacer

et les donnée "date sont modifier

cellule E7 =2

cellule E4 = mars17

action - rapatrier tous les commentaires de la feuille "commentaire" sur la feuille "planning"

mais le commentaire suivant

A2 = Mr DUPOND Jean

B2 = 1 mars 2017

C2 = le commentaire

ne peut être copier vis-à-vis la date 1 mars 2017 puisque cette date n'est plus là

je pense qu'il faut rapatrier seulement les commentaires des date actuellement présente sur la feuille planning

est-ce bien ça ?

ps/ ton planning est beau, je trouve que c'est une très belle présentation

Le 08/04/2017 à 09:04

Bonjour sabV,

sabV a écrit :

ne peut être copier vis-à-vis la date 1 mars 2017 puisque cette date n'est plus là

je pense qu'il faut rapatrier seulement les commentaires des date actuellement présente sur la feuille planning

est-ce bien ça ?

Oui,tu as tout compris, il ne faut rapatrier que que les commentaires des date actuellement présente sur la feuille planning .

Merci pour ton aide.

Le 10/04/2017 à 04:03

Bonjour,

Voici mon premier test "réussi" j'ai fait le transfert des commentaires directement dans les cellules concernées,

je trouve le code trop lent, peut être vaudrait-il essayé avec un Array

le code suivant est aussi dans le fichier joint

Sub Triangleisocèle10_Cliquer()
s = Val(Right(ActiveSheet.Shapes(Application.Caller).Name, 2))
TriangleIsocèle s
End Sub
Sub Triangleisocèle12_Cliquer()
s = Val(Right(ActiveSheet.Shapes(Application.Caller).Name, 2))
TriangleIsocèle s
End Sub

Sub TriangleIsocèle(clik)
Application.ScreenUpdating = False
Dim DicoNom As New Scripting.Dictionary
Dim DicoComment As New Scripting.Dictionary
Dim LastRw1 As Long, LastRw2 As Long
Dim sh1, sh2, rw As Long, cl As Integer, i As Integer
Dim val1, val2, cle1, t1, t2, cmt

 Set sh1 = Sheets("Planning")
 Set sh2 = Sheets("Commentaire")
 LastRw1 = sh1.Cells(Rows.Count, 4).End(xlUp).Row
 LastRw2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row + 1

For Each cmt In ActiveSheet.Comments
    Set isect1 = Application.Intersect(Range(cmt.Parent.Address), Range("E9:E" & LastRw1))
    Set isect2 = Application.Intersect(Range(cmt.Parent.Address), Range("AW9:AW" & LastRw1))

    If Not isect1 Is Nothing Or Not isect2 Is Nothing Then
        'val1 = Nom   val2 = date
        val1 = sh1.Cells(cmt.Parent.Row, 4)
        val2 = Format(sh1.Cells(7, cmt.Parent.Column).Value, "0")
        t = "Match(""" & val1 & """&" & val2 & "," & sh2.Name & "!" & Range("A:A").Address(0, 0) & "&" & sh2.Name & "!" & Range("B:B").Address(0, 0) & ",0)"
        n = Evaluate(t)
        If IsError(n) Then
'        'ajout de Nom date et comment sur la feuille Commentaire
           sh2.Cells(LastRw2, 1) = val1
           sh2.Cells(LastRw2, 2) = val2
           sh2.Cells(LastRw2, 3) = cmt.Text
           LastRw2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row + 1
       End If
    End If
Next

  Select Case clik
    Case 10:  ' déplacement arrière
      sh1.Range("E9:AV" & LastRw1).Copy
      sh1.Range("F9").PasteSpecial xlPasteComments
      Application.CutCopyMode = False
      sh1.Range("E9:E" & LastRw1).ClearComments
      sh1.Range("E7").Value = sh1.Range("E7").Value - 1
     For i = 9 To LastRw1
        val1 = sh1.Cells(i, "D")
        val2 = Format(sh1.Cells(7, "E").Value, "0")
        t = "Match(""" & val1 & """&" & val2 & "," & sh2.Name & "!" & Range("A:A").Address(0, 0) & "&" & sh2.Name & "!" & Range("B:B").Address(0, 0) & ",0)"
        n = Evaluate(t)
        If Not IsError(n) Then
         With sh1
            .Cells(i, "E").AddComment sh2.Cells(n, "C").Value
         End With
        End If
     Next

    Case 12:   ' déplacement avant
      sh1.Range("F9:AW" & LastRw1).Copy
      sh1.Range("E9").PasteSpecial xlPasteComments
      Application.CutCopyMode = False
      sh1.Range("AW9:AW" & LastRw1).ClearComments
      sh1.Range("E7").Value = sh1.Range("E7").Value + 1
      For i = 9 To LastRw1
        val1 = sh1.Cells(i, "D")
        val2 = Format(sh1.Cells(7, "AW").Value, "0")
        t = "Match(""" & val1 & """&" & val2 & "," & sh2.Name & "!" & Range("A:A").Address(0, 0) & "&" & sh2.Name & "!" & Range("B:B").Address(0, 0) & ",0)"
        n = Evaluate(t)
        If Not IsError(n) Then
         With sh1
            .Cells(i, "AW").AddComment sh2.Cells(n, "C").Value
         End With
        End If
      Next
   End Select
   sh1.Range("D9").Select
Application.ScreenUpdating = True
End Sub
13benoist28200-mon-planning.xlsm (153.27 Ko)
Le 11/04/2017 à 06:24

Bonjour SabV,

J'ai essayé ton code, il fonctionne parfaitement mais c'est vrai qu'il est un peu lent.

J'ai réussi à faire ceci, un peu plus rapide:

Private Sub CommandButton1_Click()

Dim DerLigne%, Derligne3%

    DerLigne = Sheets("Commentaires").Range("A" & Rows.Count).End(xlUp).Row + 1
    Derligne3 = Sheets("Planning").Range("D" & Rows.Count).End(xlUp).Row

    If Not Application.Intersect(ActiveCell, Range("E9:AW" & Derligne3)) Is Nothing Then

        NoLigne = ActiveCell.Row
        NoColonne = ActiveCell.Column

'Ajouter le commentaire      
        With Sheets("Commentaires")
            .Range("A" & DerLigne).Value = Cells(NoLigne, 4).Value
            .Range("B" & DerLigne).Value = Cells(7, NoColonne).Value
            .Range("C" & DerLigne).Value = TextBox1.Value
            .Range("E" & DerLigne).Value = Now()
        End With

    End If

'Supprimer les doublons les plus anciens 
    For L = Sheets("Commentaires").Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
    For j = Sheets("Commentaires").Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
        If Sheets("Commentaires").Cells(j, 4) = Sheets("Commentaires").Cells(L, 4) Then
        If Sheets("Commentaires").Cells(j, 5) < Sheets("Commentaires").Cells(L, 5) Then
        Sheets("Commentaires").Cells(j, 1).EntireRow.Delete
    End If: End If
    Next j: Next L

'Supprimer les commentaires (lignes vides)
    With Sheets("Commentaires")
        For i = .Range("A" & .Rows.Count).End(xlUp).Row To 2 Step -1
            If .Range("C" & i).Value = "" Then
                .Rows(i).Delete
            End If
        Next i
    End With

Call AjoutCommentaires

    Unload Me

End Sub
Sub AjoutCommentaires()

On Error Resume Next
Dim DerLigne%, DerLigne2%
Dim Comm As String

DerLigne = Sheets("Planning").Range("D" & Rows.Count).End(xlUp).Row
DerLigne2 = Sheets("Commentaires").Range("D" & Rows.Count).End(xlUp).Row

Application.ScreenUpdating = False

With Sheets("Planning")
    .Range("E7:AW7").NumberFormat = "General" 'Je mets les dates en format standard
    .Range("E9:AW" & DerLigne).ClearComments  'Je supprime les commentaires de la plage

    For Each cell In .Range("E9:AW" & DerLigne)   'Je fais une boucle : si commentaire DATE/NOM alors insertion planning
        For NoLigne = 9 To DerLigne
            For NoColonne = 5 To 49

                Comm = ((Cells(NoLigne, 4)) & (Cells(7, NoColonne)))
                For i = 2 To DerLigne2
                    If Sheets("Commentaires").Range("D" & i) = Comm Then

                                    .Cells(NoLigne, NoColonne).AddComment
                                    .Cells(NoLigne, NoColonne).Comment.Text Text:=Sheets("Commentaires").Range("C" & i).Value
                    End If
                Next i
            Next NoColonne
        Next NoLigne

    Next

    .Range("E7:AW7").NumberFormat = "dd" Je remets les date en format "jj"
End With

Application.ScreenUpdating = True
End Sub

Je vais voir si je peux encore l’améliorer afin qu'il soit encore plus rapide.

Un grand merci pour ton aide et le temps que tu m'as accordé.

Cordialement

Benoist

Rechercher des sujets similaires à "commentaire planning"