Creare una mail settimanale con dati estratti da un file excel secondo la regola della data compresa tra un lunedi e il seguente

Question

Nel mio ufficio ho la necessita' di inviare ogni lunedi mattina alle 9.00 una email in cui venga inserita una tabella estratta da un foglio excel secondo le date inserite in 2 colonne specifiche e la mail inviata a 3/4 indirizzi email sempre gli stessi.

praticamente secondo le date inserite nelle due colonne indicate vorrei che venisse inviata la tabella come nell'immagine sotto sempre alle stesse 4 persone ogni lunedi.

tenendo conto che le righe da prendere in considerazione sono solo quelle che comprendono le date passate rispetto al lunedi di invio e quelle comprese tra il lunedi di invio e il lunedi successivo. posso anche inviare il file se serve per capire meglio.

Answer 1

Ciao Norman,

non riesco a scaricare il file, purtroppo ho visto la notifica solo oggi.

vorrei verificare i cambi che hai fatto alle celle, non ricordo di avere celle unite nella parte da cui prendere i dati.

donatella

Answer 2

Ciao Norman,

credo si sia perso uno dei miei messaggi, avevo scritto di aver sostituito il file condiviso con uno nel quale avevo unito le due date di due date in un'unica colonna "Deadline".

per quanto riguarda le date non ho capito cosa intendi con sostituito le date con il venerdi, l'immagine era di esempio se avessi voluto inviare la mail con le scadenze tra lunedi 02/10 e lunedi 09/10 e mettendo nella tabella nella mail la tabella con le colonne come da immagine.

questo e' il file con le deadline in una colonna

RENOV_VAR RPN tracker.xlsx

Donatella

Answer 3

Ciao Donatella,

Potresti scaricare il mio file di prova Donatella20230926.xlsm

Purtroppo ho pubblicato un link errato, che ora ho corretto.

Il link corretto dovrebbe essere:

                           ****   [**Donatella20230926.xlsm**](https://www.dropbox.com/t/Oaa4lGOIvATidvfJ "www.dropbox.com")

===

Regards,

Norman

Answer 4

Ciao Donatella,

ho modificato il file unendo le due deadline in un unica colonna cosi non dovrei sbagliare nella selezione del range di date

RENOV_VAR RPN tracker.xlsx

.

Ho scaricato il tuo file e ho apportato le seguente modifiche:

• Ho sostituito tutte le aree delle celle unite con una riga di celle formattate normalmente. L'ho fatto perché le celle unite sono un incubo, sia per Excel che per VBA. Inoltre, l'ho fatto per consentire la seconda modifica:
• Ho convertito le colonne A: O dei tuoi dati in una tabella strutturata di Excel

Effettuate le modifiche,sostituisci il codice precedente con la seguente versione:

'========>>

Option Explicit

'-------->>

Public Sub Tester()

Dim WB As Workbook 

Dim SH As Worksheet 

Dim oTabella As ListObject 

Dim Rng As Range 

Dim iStartDate As Long, iEndDate As Long 

Const sFoglio As String = **"RENOV\_VAR SUMMARY"                                                    '<<=== Modifica** 

Const sTabella As String = **"Table1"                                                                                '<<=== Modifica** 

Const sDestinatarie As String =**"PippoAToutlook.com;PlutoATATgmail.com"            '<<=== Modifica** 

Const sOggetto As String = **"Esempio\_Mail\_HTML"                                                      '<<=== Modifica** 

Set WB = ThisWorkbook 

Set SH = WB.Sheets(sFoglio) 

Set oTabella = SH.ListObjects(sTabella) 

iStartDate = CLng(MyMondayDate(Date, -1) + 5) 

iEndDate = CLng(MyMondayDate(Date, 1)) 

With oTabella 

    .DataBodyRange.Columns(10).Resize(, 2).NumberFormat = "General" 

    With .Range 

    .AutoFilter Field:=10, Criteria1:= \_ 

    ">=" & iStartDate, Operator:=xlAnd, Criteria2:="<=" & iEndDate 

    oTabella.DataBodyRange.Columns(10).Resize(, 2).NumberFormat = "dd/mm/yy" 

        On Error Resume Next 

        Set Rng = .SpecialCells(xlCellTypeVisible) 

        On Error GoTo 0 

    End With 

   If Not Rng Is Nothing Then 

    Call Invia\_Mail\_HTML(Rng, sDestinatarie, sOggetto) 

    Else 

        Call MsgBox(Prompt:="Nessun dato trovato per la settimana corrispondente!", \_ 

        Buttons:=vbCritical, \_ 

        Title:="REPORT") 

    End If 

    .AutoFilter.ShowAllData 

     oTabella.DataBodyRange.Columns(10).Resize(, 2).NumberFormat = "dd/mm/yy" 

End With 

End Sub

'-------->>

Public Function MyMondayDate(pdat As Date, iWeekOffset) As Date

MyMondayDate = DateAdd("ww", iWeekOffset, pdat - (Weekday(pdat, vbMonday) - 1)) 

End Function

'-------->>

Public Sub Invia_Mail_HTML(oRng As Range, sRecipient As String, sSubject As String)

Dim oOutlook As Object 

Dim oMail As Object 

With Application 

    .EnableEvents = False 

    .ScreenUpdating = False 

End With 

Set oOutlook = CreateObject("Outlook.Application") 

Set oMail = oOutlook.CreateItem(0) 

On Error Resume Next 

With oMail 

    .To = sRecipient 

    .CC = "" 

    .BCC = "" 

    .Subject = sSubject 

    .HTMLBody = RangetoHTML(oRng) 

    .Send 

    .Display  '\\ .Send 

End With 

On Error GoTo 0 

With Application 

    .EnableEvents = True 

    .ScreenUpdating = True 

End With 

Set oMail = Nothing 

Set oOutlook = Nothing 

End Sub

'--------->>

Public Function RangetoHTML(Rng As Range)

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

'<<========

Potresti scaricare il mio file di prova Donatella20230926.xlsm

===

Regards,

Norman

Answer 5

ho modificato il file unendo le due deadline in un unica colonna cosi non dovrei sbagliare nella selezione del range di date

RENOV_VAR RPN tracker.xlsx