Creare una mail da excel

Question

Buongiorno,

Vorrei sapere se possibile ed se si creare una macro che mi copi determinati dati in funzione del giorno direttamente su una mail e poi chiudere automaticamente il foglio excel.

Io ho un foglio excel con varie schede, la scheda di interesse si chiama "Year_2023"

su questo folgio ci sono tutti i lavori fatti o da fare dall'inizio dell'anno 2023 pertanto a me servirebbe che al momento della esecuzione della routine, la macro copi tutte le righe corrisponenti alla data odierna dalla colonna "A" alla colonna "F" e la incolla su una mail avente come oggetto " Electrical daily job report & data odierna"

Ad intestazione foglio ci sono anche le intestazioni di colonna.

Se è possibile inserirle le intestazioni sulle varie colonne la mail sarebbe ancora più completa altrimenti va anche bene come da immagine allegata.

e questa è un'immagine del foglio di lavoro da dove estrapolare i dati, in funzione della data odierna, dalla colonna "A" alla colonna "F".

Spero si possa fare e come sempre in un vostro aiuto.

Answer 1

Ciao Giuseppe,

il codice completo aggiornato è il seguente:

'========>>

Option Explicit

'-------->>

Public Sub Tester()

Dim SH As Worksheet 

Dim oTable As ListObject 

Dim Rng As Range 

Const sFoglio As String = "Year\_2023" 

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

Set SH = ThisWorkbook.Worksheets(sFoglio) 

Set oTable = SH.ListObjects(sTabella) 

With oTable 

    .DataBodyRange.Columns(1).NumberFormat = "General" 

    .Range.AutoFilter Field:=1, Criteria1:= \_ 

        CLng(Date - 2) 

    Set Rng = .Range.Columns(1).Resize(, 6).SpecialCells(xlCellTypeVisible) 

    .AutoFilter.ShowAllData 

    If Not Rng Is Nothing Then 

        Call Mail\_Report(Rng) 

    End If 

    .Range.Columns(1).NumberFormat = "dd/mm/yyyy" 

End With 

End Sub

'-------->>

Public Sub Mail_Report(oRng As Range)

Dim oOutlook As Object 

Dim oMail As Object 

Const sEmail\_Address As String ='"**PippoCHIOCCIOLAgmail.com**"                        **'<<=== Modifica** 

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 = sEmail\_Address 

    .CC = "" 

    .BCC = "" 

    .Subject = " Electrical daily job report " & Format(Date - 2, "dd/mm/yyyy") 

    .HTMLBody = RangetoHTML(oRng) 

    .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(Date - 2, "dd-mm-yy h-mm-ss") & ".htm" 

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

'<<========

Se dovessi avere ancora problemi in sospeso, ti chiederei gentilmente di inviarmi il tuo file, comprensivo del relativo codice VBA.

Detto questo, sembrerebbe che ora tu abbia ottenuto i risultati originariamente richiesti.

===

Regards,

Norman

Answer 2

Ciao Giuseppe,

In un modulo standard, prova qualcosa del genere:

'========>>

Option Explicit

'-------->>

Public Sub Tester()

Dim SH As Worksheet 

Dim oTable As ListObject 

Dim Rng As Range 

Const sFoglio As String = **"Year\_2023"** 

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

Set SH = ThisWorkbook.Worksheets(sFoglio) 

Set oTable = SH.ListObjects(sTabella) 

With oTable 

    .DataBodyRange.Columns(1).NumberFormat = "General" 

    .Range.AutoFilter Field:=1, Criteria1:= \_ 

        CLng(Date - 2) 

    .DataBodyRange.Columns(1).NumberFormat = "dd/mm/yyyy" 

    Set Rng = .Range.SpecialCells(xlCellTypeVisible) 

    If Not Rng Is Nothing Then 

        Call Mail\_Report(Rng) 

    End If 

End With 

End Sub

'-------->>

Public Sub Mail_Report(oRng As Range)

Dim oOutlook As Object 

Dim oMail As Object 

Const sEmail\_Address As String = '"**PippoCHIOCCIOLAgmail.com**"      **'<<=== Modifica**

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 = sEmail\_Address 

    .CC = "" 

    .BCC = "" 

    .Subject = " Electrical daily job report " & Format(Date, "dd/mm/yyyy") 

    .HTMLBody = RangetoHTML(oRng) 

    '        .Display 

    .Send   'or use .Display 

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" 

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

'<<========

===

Regards,

Norman

Answer 3

Buongiorno Norman,

innanzitutto grazie per l'immediata risposta e scusami una domanda, cosa devo mettere al posto di "table1" ?

Perchè quando testo l'istruzione va in debug

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

Grazie

Giuseppe

Answer 4

Ciao Giuseppe,

Per includere solo le colonne A:F nel rapporto email, nella procedura Tester, sostituisci l'istruzione

 Set Rng = .Range.SpecialCells(xlCellTypeVisible)

con:

   Set Rng = .Range**.Columns(1).Resize(, 6)**.SpecialCells(xlCellTypeVisible)

===

Regards,

Norman