Optimiser un planning

Bonjour,

Je souhaiterais optimiser un planning et envoyer une situation journalière par mail.

Le fichier joint comporte une feuille "mail" qui générera l'envoi du mail en fonction des données présentes dans la feuille "JUIN"

Exemple : sur la feuille "mail" dans les cases D14:D19 j'aimerais reporté la situation des personnels en fonction du planning dans la feuille de "JUIN"

Cette idée je la réitérerai sur les mois suivants ensuite.

En somme, si le 25 juin j'ai Lolo et Théo "En Service" je souhaiterais que ce binôme soit inscrit dans la case idoine de la feuille "mail" idem pour les autres cases.

J'ai déjà le code pour générer le mail mais je ne sais pas du tout comment implémenter ma nouvelle problématique. Je vous remercie par avance pour votre aide

Sub Envoi_SPA()
' Envoi_SPA_ Macro

Dim OutlookApp As Object
Dim MailItem As Object
Dim SigString As String
Dim Signature As String

' Vérifier si Outlook est ouvert

On Error Resume Nex
Set OutlookApp = GetObject(, "Outlook.Application")
On Error GoTo 0

' Si Outlook n'est pas ouvert, ouvrir une nouvelle instance
'If OutlookApp Is Nothing Then
Set OutlookApp = CreateObject("Outlook.Application")
'End If

' Créer un nouvel e-mail
Set MailItem = OutlookApp.CreateItem(0)

' Remplir les détails de l'e-mail
With MailItem
' Afficher l'e-mail
.Display
.To = Range("B4")
.Subject = Range("B8")
.HTMLBody = RangetoHTML(Range("B10:C20"))
' Ajouter des pièces jointes si nécessaire
' .Attachments.Add "chemin_de_la_piece_jointe"

End With
 ' Libérer les objets
Set MailItem = Nothing
Set OutlookApp = Nothing
ActiveWorkbook.Save
Application.WindowState = xlNormal
ActiveWindow.SmallScroll Down:=0
ActiveWorkbook.Save
End Sub

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
Dim fso         As Object
Dim ts          As Object
Dim TempFile    As String
Dim TempWB      As Workbook 

TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select

Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With

'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With

'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                  "align=left x:publishsource=")

'Close TempWB
TempWB.Close savechanges:=False

'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function

Bonjour guibs,

Je vois que vous ne semblez pas suivre ce qu'on vous donne comme solution

1) pourquoi mettre en commentaire ces lignes ?
alors que le code que j'avais donné et que vous pouvez trouver les comporte bien...

' Si Outlook n'est pas ouvert, ouvrir une nouvelle instance
'If OutlookApp Is Nothing Then
Set OutlookApp = CreateObject("Outlook.Application")
'End If

2) Vous demandiez ici, comment mettre vote signature
https://forum.excel-pratique.com/excel/vba-signature-mail-pbm-affichage-logo-194091
Et dans ce code et bien plus de signature...

Bref, c'était juste pour vous dire que j'allais m'abstenir de vous aider cette fois

Bonne continuation

Bonjour,

C'est une erreur de ma part lorsque j'ai supprimé les sauts de ligne. J'ai bien appliqué vos conseils qui ont très bien fonctionné. Désolé si cela vous a froissé. Merci pour votre aide. Ma seconde problématique est toujours d'actualité et je comprends votre message.

Bonjour guibs, le fil, le forum,

Pour remplir la plage "D14:D19 de la feuille "mail" avec les noms des personnes selon leur statut à la date du jour.

Sub Envoi_SPA()
    Dim Lign As Integer, LignM As Integer
    Dim Dlig As Integer, Spa As String
    Dim TargetCell As Range, TargetCol As Integer

    ' La date du jour
    Dim VarianceDate As String: VarianceDate = Format(Date, "dd/mm/yyyy")
'    VarianceDate = Replace(VarianceDate, "-", "/") '' si besoin de modifier les séparateurs

    ' cherche la colonne de la date du jour
    Set TargetCell = Worksheets("JUIN").Rows("11").Find(What:=CDate(VarianceDate), LookIn:=xlFormulas, LookAt:=xlPart)

    ' si trouvée
    If Not TargetCell Is Nothing Then
        TargetCol = TargetCell.Column

        With Worksheets("mail")
            .Range("D14:D19").ClearContents ' vide la plage
        End With

        With Worksheets("JUIN")
            Dlig = .Cells(Rows.Count, "A").End(xlUp).Row ' dernière ligne

            For Lign = 14 To 19    ' boucle les lignes feuille "mail" colonne "B"
                Select Case Worksheets("mail").Cells(Lign, "B").Value    ' transpose le type d'événement
                    Case "En service"
                        Spa = "X"
                    Case "En repos"
                        Spa = "R"
                    Case "En astreinte"
                        Spa = "A"
                    Case "En HO"
                        Spa = "HO"
                    Case "En congés"
                        Spa = "C"
                    Case "TCT"
                        Spa = "TCT"
                    Case Else
                        GoTo Reprise
                End Select

                ' boucle sur les lignes feuille "JUIN" colonne date du jour
                For LignM = 12 To Dlig
                    If .Cells(LignM, TargetCol) = Spa Then
                        ' si correspondance écrire feuille "mail"
                        Worksheets("mail").Cells(Lign, "D").Value = Worksheets("mail").Cells(Lign, "D").Value & " - " & .Cells(LignM, 1).Value
                    End If
                Next LignM
Reprise:
            Next Lign
        End With
    Else
        MsgBox "Aucune correspondance trouvée pour la date du jour.", vbInformation
    End If
End Sub

Bizz

Bonjour Bizarre,

Merci pour ta réponse rapide. Je ne suis pas sur place pour tester, en déplacement . Je fais au plus vite.

Juste une question. Que dois je implémenter dans ton code pour rajouter les feuilles correspondant a tous les autres mois de l'année ?

exemple ici c'est "JUIN" mais évidemment il faudra plus tard réitérer pour les feuilles "JUILLET, AOUT, SEPTEMBRE" etc.

J'imagine que le code egalement s'execute en temps reel en fonction du jour actuel ?

Je dois ajouter ce code en dessous du code existant concernant lageneration du mail on est d'accord ?

Bonjour guibs, le fil, le forum,

J'ai modifié le nom de ma macro, il restera au début de ta macro "Envoi_SPA" d'ajouter un appel .

À placer sous la macro "Envoi_SPA", puis ajouter un appel à cette macro ainsi :

Sub Envoi_SPA()
' Envoi_SPA_ Macro

Dim OutlookApp As Object
Dim MailItem As Object
Dim SigString As String
Dim Signature As String

' Vérifier si Outlook est ouvert

On Error Resume Nex
Set OutlookApp = GetObject(, "Outlook.Application")
On Error GoTo 0

' Si Outlook n'est pas ouvert, ouvrir une nouvelle instance
'If OutlookApp Is Nothing Then
Set OutlookApp = CreateObject("Outlook.Application")
'End If

Call ActualiserSpa  ' ligne à ajouter 
...
...
...

Sub ActualiserSpa()
    Dim Lign As Integer, LignM As Integer
    Dim Dlig As Integer, Spa As String
    Dim TargetCell As Range, TargetCol As Integer
    Dim Lemois As Worksheet

    ' Détermine la feuille selon le mois de l'année
    Set Lemois = Worksheets(UCase(Format(Date, "mmm")))

    ' La date du jour
    Dim VarianceDate As String: VarianceDate = Format(Date, "dd/mm/yyyy")
    VarianceDate = Replace(VarianceDate, "-", "/") '' si besoin de modifier les séparateurs

    ' cherche la colonne de la date du jour
    Set TargetCell = Lemois.Rows("11").Find(What:=CDate(VarianceDate), LookIn:=xlFormulas, LookAt:=xlPart)

    ' si trouvée
    If Not TargetCell Is Nothing Then
        TargetCol = TargetCell.Column
        Worksheets("mail").Range("D14:D19").ClearContents ' vide la plage

        With Lemois
            Dlig = .Cells(Rows.Count, "A").End(xlUp).Row ' dernière ligne

            For Lign = 14 To 19    ' boucle les lignes feuille "mail" colonne "B"
                Select Case Worksheets("mail").Cells(Lign, "B").Value    ' transpose le type d'événement
                    Case "En service"
                        Spa = "X"
                    Case "En repos"
                        Spa = "R"
                    Case "En astreinte"
                        Spa = "A"
                    Case "En HO"
                        Spa = "HO"
                    Case "En congés"
                        Spa = "C"
                    Case "TCT"
                        Spa = "TCT"
                    Case Else
                        GoTo Reprise
                End Select

                ' boucle sur les lignes feuille "JUIN" colonne date du jour
                For LignM = 12 To Dlig
                    If .Cells(LignM, TargetCol) = Spa Then
                        ' si correspondance écrire feuille "mail"
                        Worksheets("mail").Cells(Lign, "D").Value = Worksheets("mail").Cells(Lign, "D").Value & " - " & .Cells(LignM, 1).Value
                    End If
                Next LignM
Reprise:
            Next Lign
        End With
    Else
        MsgBox "Aucune correspondance trouvée pour la date du jour.", vbInformation
    End If
End Sub

Bizz

Bonjour Bizarre,

Ton code fonctionne très bien.

J'ai voulu en revanche scinder les actions en 2 modules bien distincts car j'ai pas compris forcément où situer ton code avec celui de la génération du mail. Ce qui fait que j'ai 2 boutons 1 pour chaque module.

Egalement je me posais cette question pour les prénoms qui sont séparés par un tiret. Ca c'est parfait mais du coup j'ai aussi un tiret au début des prénoms que je trouve en trop comment garder le tiret qui sépare le binome de prénom mais l'enlever au début ?

Bonjour guibs, le fil, le forum,

Afin ne pas avoir un tiret en début de cellule de la colonne D, ajoutons une condition.

' si la cellule est vide, ajouter le premier nom
puis
' sinon, le contenu de la  cellule + tiret + nom suivant

Change la fin de "Sub ActualiserSpa()" pour ceci :

                ' boucle sur les lignes feuille "JUIN" colonne date du jour
                For LignM = 12 To Dlig
                    If .Cells(LignM, TargetCol) = Spa Then
                        ' si correspondance écrire feuille "mail"

                        ' si la cellule est vide, ajouter le premier nom
                        If Len(Worksheets("mail").Cells(Lign, "D").Value) = 0 Then
                            Worksheets("mail").Cells(Lign, "D").Value = .Cells(LignM, 1).Value

                        Else  ' si la cellule n'est pas vide > le contenu de la  cellule + tiret + autre nom
                        Worksheets("mail").Cells(Lign, "D").Value = Worksheets("mail").Cells(Lign, "D").Value & " - " & .Cells(LignM, 1).Value
                        End If
                    End If
                Next LignM
Reprise:
            Next Lign
        End With
    Else
        MsgBox "Aucune correspondance trouvée pour la date du jour.", vbInformation
    End If
End Sub

Bizz

Merci Bizarre ca fonctionne à merveille. Un grand merci pour tes compétences ca m'a beaucoup aidé

Bonjour guibs,

Au plaisir

Bizz