• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 314
  • Last Modified:

Macro to take date of Pivot results to Outlook msg template fields

Hi,

Is it possible for a macro to run through the results of a refreshed pivot table to take the values into an Outlook mail.

From the sample attached:
It would need to take the order ref and use the data sheet to replace the fields which are between the # signs. New rows would be needed if a Unit has more than one order in the 1 day alert stage.

One email would be needed for each Unit. Could a macro actually acheive this?
Book1.xlsx
Sample.msg
0
codevu
Asked:
codevu
  • 5
  • 4
1 Solution
 
Zack BarresseCEOCommented:
Hi there,

This will not look at the PivotTable, but the data source on your Data worksheet.  Please note that it does not enter an email address, nor does it automatically send the email, but rather just displays it.  This code should go into a standard module of the workbook which houses this data.

Option Explicit

Sub SendAlertEmail()

    '/// Reference set to (Tools | References):
    '///   Microsoft Outlook 14.0 Object Library
    '///   Microsoft Scripting Runtime

    Dim WS                      As Worksheet
    Dim rCheck                  As Range
    Dim rAlert                  As Range
    Dim rCell                   As Range
    Dim rData                   As Range
    Dim OL                      As Outlook.Application
    Dim olMail                  As Outlook.MailItem
    Dim bOLOpen                 As Boolean
    Dim oDic                    As New Scripting.Dictionary
    Dim vKey                    As Variant
    Dim sBody                   As String

    Call TOGGLEEVENTS(False)

    Set WS = ThisWorkbook.Worksheets("Data")
    Set rData = WS.Range("A1:G" & WS.Cells(WS.Rows.Count, 1).End(xlUp).Row)

    For Each rCell In WS.Range("F2", WS.Cells(WS.Rows.Count, "F").End(xlUp)).Cells
        If oDic.Exists(rCell.Value) = False Then
            If Evaluate("=COUNTIFS('Data'!F:F,""Team1"",'Data'!G:G,""Yes"")") > 0 Then
                oDic.Add rCell.Value, rCell.Value
            End If
        End If
    Next rCell

    bOLOpen = True
    On Error Resume Next
    Set OL = GetObject(, "Outlook.Application")
    If OL Is Nothing Then
        Set OL = CreateObject("Outlook.Application")
        bOLOpen = False
    End If
    On Error GoTo 0

    WS.Range("C:C,F:F,G:G").EntireColumn.ColumnWidth = 0
    For Each vKey In oDic.Items

        Set olMail = OL.CreateItem(olMailItem)

        olMail.Subject = oDic.Item(vKey) & " - 1 Day Alert - Orders Due"

        rData.AutoFilter 6, oDic.Item(vKey)
        rData.AutoFilter 7, "Yes"

        olMail.HTMLBody = RangetoHTML(rData.SpecialCells(xlCellTypeVisible))

        WS.AutoFilterMode = False

        olMail.Display

    Next vKey

    WS.Cells.EntireColumn.AutoFit

    If bOLOpen = False Then OL.Quit

    Call TOGGLEEVENTS(True)

End Sub

Function RangetoHTML(rng As Range)
    ' Graciously used/adapted from http://www.rondebruin.nl/mail/folder3/mail4.htm
    ' By Ron de Bruin 28-Oct-2006
    ' Working in Office 2000-2010

    Dim fso                     As Object
    Dim ts                      As Object
    Dim TempFile                As String
    Dim wbTemp                  As Workbook
    Dim wsTemp                  As Worksheet

    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 wbTemp = Workbooks.Add(1)
    Set wsTemp = wbTemp.Worksheets(1)
    wsTemp.Range("A1").Value = "1 Day Alert - Orders due within 1 working day"
    wsTemp.Range("A3").Value = "Please be aware that these orders are due within 1 day. Please provide an update on the status."
    wsTemp.Range("A5").PasteSpecial Paste:=8
    wsTemp.Range("A5").PasteSpecial xlPasteValues, , False, False
    wsTemp.Range("A5").PasteSpecial xlPasteFormats, , False, False
    wsTemp.Range("A5:D5").Font.Bold = True
    wsTemp.Range("A5:D" & wsTemp.Cells(wsTemp.Rows.Count, 1).End(xlUp).Row).BorderAround xlContinuous
    wsTemp.Range("A5:D" & wsTemp.Cells(wsTemp.Rows.Count, 1).End(xlUp).Row).Borders(xlInsideHorizontal).LineStyle = xlContinuous
    wsTemp.Range("A5:D" & wsTemp.Cells(wsTemp.Rows.Count, 1).End(xlUp).Row).Borders(xlInsideVertical).LineStyle = xlContinuous
    wsTemp.Cells(1, 1).Select
    Application.CutCopyMode = False
    On Error Resume Next
    wsTemp.DrawingObjects.Visible = True
    wsTemp.DrawingObjects.Delete
    On Error GoTo 0
    wsTemp.Cells(wsTemp.Rows.Count, 1).End(xlUp).Offset(2).Value = "Thanks"
    wsTemp.Range("A1:D1").Merge
    wsTemp.Range("A3:D3").Merge
    wsTemp.Cells.EntireColumn.AutoFit
    wsTemp.Range("A:D").ColumnWidth = 18
    wsTemp.Range("A1:D3").WrapText = True
    wsTemp.Range("A1:D3").Font.Bold = False

    'Publish the sheet to a htm file
    With wbTemp.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=wsTemp.Name, _
         Source:=wsTemp.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 wbTemp
    wbTemp.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set wbTemp = Nothing
End Function

Public Sub TOGGLEEVENTS(blnState As Boolean)
    Application.DisplayAlerts = blnState
    Application.EnableEvents = blnState
    Application.ScreenUpdating = blnState
    If blnState Then Application.CutCopyMode = False
    If blnState Then Application.StatusBar = False
End Sub

Open in new window


Also please note that I did set two references here in order to use early binding.  You don't have to have them, but I prefer them.  If this file will move from computer to computer then I would recommend using late binding and we can adjust the code accordingly.  If you try to use the code without setting the proper references then it will fail.  Please look at the top of the code for the commented out code which tells which references to use, there is two of them.

Please let us know if you have any questions.  The code has been tested with the supplied workbook and works for me, getting it as close to your message as possible.

HTH

Regards,
Zack Barresse
0
 
codevuAuthor Commented:
I have tested it in the sample and got the same positive result - this is great. I clearly complicated things trying to work with the pivot instead of the raw data.

What happens if I add more data columns - is there a way to define particular ranges?

I'm also curious about line 28 and how it works - Test1 is coded there but how does it run through them all and replace Test1?

I am happy to add the references as needed. Not many people will use the workbook and it will be stored centrally.
0
 
Zack BarresseCEOCommented:
Oh darn it, I'm sorry.  That line of code should've been changed.  I hard coded it for testing.  

This line...
If Evaluate("=COUNTIFS('Data'!F:F,""Team1"",'Data'!G:G,""Yes"")") > 0 Then

Open in new window

... should actually be changed to...
If Evaluate("=COUNTIFS('Data'!F:F," & rCell.Value & ",'Data'!G:G,""Yes"")") > 0 Then

Open in new window


Very sorry about that, my very large oversight.

We can make the range variable depending on what you want.  I went by your example, so I hid certain columns and filtered what you showed.  If you want other ranges, just let us know how you'd like to show it.  We can do pretty much anything you'd like, so long as you can articulate it to us in detail.  :)

Zack
0
Free recovery tool for Microsoft Active Directory

Veeam Explorer for Microsoft Active Directory provides fast and reliable object-level recovery for Active Directory from a single-pass, agentless backup or storage snapshot — without the need to restore an entire virtual machine or use third-party tools.

 
codevuAuthor Commented:
Hi Zack,

Sorry about the delay -

My working sheet has about 40 columns - is it best to set each unwanted column in line 43?
0
 
Zack BarresseCEOCommented:
codevu,

Sorry I haven't been able to respond.  I'll take a look at this tonight.

Zack
0
 
codevuAuthor Commented:
Thanks Zack,

No problem, I look forward to your input
0
 
Zack BarresseCEOCommented:
Okay, so I found another problem with the code - I was missing quotes around the "Team1" in the formula VBA was using.  Found, fixed, and in the below code.

To answer your question, yes, I would put all of the columns you don't want to see in the message to hidden.  They all get unhidden afterwards anyway.  If they're contiguous you can reference them like G:Z, etc.  So if you wanted to hide column C and then columns F through Z, leaving column D unhidden, you would put that range like this...

"C:C,F:Z"

...make sense?

Here is the code with the amendement...

Option Explicit

Sub SendAlertEmail()

    '/// Reference set to (Tools | References):
    '///   Microsoft Outlook 14.0 Object Library
    '///   Microsoft Scripting Runtime

    Dim WS                      As Worksheet
    Dim rCheck                  As Range
    Dim rAlert                  As Range
    Dim rCell                   As Range
    Dim rData                   As Range
    Dim OL                      As Outlook.Application
    Dim olMail                  As Outlook.MailItem
    Dim bOLOpen                 As Boolean
    Dim oDic                    As New Scripting.Dictionary
    Dim vKey                    As Variant
    Dim sBody                   As String

    Call TOGGLEEVENTS(False)

    Set WS = ThisWorkbook.Worksheets("Data")
    Set rData = WS.Range("A1:G" & WS.Cells(WS.Rows.Count, 1).End(xlUp).Row)

    For Each rCell In WS.Range("F2", WS.Cells(WS.Rows.Count, "F").End(xlUp)).Cells
        If oDic.Exists(rCell.Value) = False Then
            If Evaluate("=COUNTIFS('Data'!F:F,""" & rCell.Value & """,'Data'!G:G,""Yes"")") > 0 Then
                oDic.Add rCell.Value, rCell.Value
            End If
        End If
    Next rCell

    bOLOpen = True
    On Error Resume Next
    Set OL = GetObject(, "Outlook.Application")
    If OL Is Nothing Then
        Set OL = CreateObject("Outlook.Application")
        bOLOpen = False
    End If
    On Error GoTo 0

    WS.Range("C:C,F:G").EntireColumn.ColumnWidth = 0
    For Each vKey In oDic.Items

        Set olMail = OL.CreateItem(olMailItem)

        olMail.Subject = oDic.Item(vKey) & " - 1 Day Alert - Orders Due"

        rData.AutoFilter 6, oDic.Item(vKey)
        rData.AutoFilter 7, "Yes"

        olMail.HTMLBody = RangetoHTML(rData.SpecialCells(xlCellTypeVisible))

        WS.AutoFilterMode = False

        olMail.Display

    Next vKey

    WS.Cells.EntireColumn.AutoFit

    If bOLOpen = False Then OL.Quit

    Call TOGGLEEVENTS(True)

End Sub

Function RangetoHTML(rng As Range)
    ' Graciously used/adapted from http://www.rondebruin.nl/mail/folder3/mail4.htm
    ' By Ron de Bruin 28-Oct-2006
    ' Working in Office 2000-2010

    Dim fso                     As Object
    Dim ts                      As Object
    Dim TempFile                As String
    Dim wbTemp                  As Workbook
    Dim wsTemp                  As Worksheet

    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 wbTemp = Workbooks.Add(1)
    Set wsTemp = wbTemp.Worksheets(1)
    wsTemp.Range("A1").Value = "1 Day Alert - Orders due within 1 working day"
    wsTemp.Range("A3").Value = "Please be aware that these orders are due within 1 day. Please provide an update on the status."
    wsTemp.Range("A5").PasteSpecial Paste:=8
    wsTemp.Range("A5").PasteSpecial xlPasteValues, , False, False
    wsTemp.Range("A5").PasteSpecial xlPasteFormats, , False, False
    wsTemp.Range("A5:D5").Font.Bold = True
    wsTemp.Range("A5:D" & wsTemp.Cells(wsTemp.Rows.Count, 1).End(xlUp).Row).BorderAround xlContinuous
    wsTemp.Range("A5:D" & wsTemp.Cells(wsTemp.Rows.Count, 1).End(xlUp).Row).Borders(xlInsideHorizontal).LineStyle = xlContinuous
    wsTemp.Range("A5:D" & wsTemp.Cells(wsTemp.Rows.Count, 1).End(xlUp).Row).Borders(xlInsideVertical).LineStyle = xlContinuous
    wsTemp.Cells(1, 1).Select
    Application.CutCopyMode = False
    On Error Resume Next
    wsTemp.DrawingObjects.Visible = True
    wsTemp.DrawingObjects.Delete
    On Error GoTo 0
    wsTemp.Cells(wsTemp.Rows.Count, 1).End(xlUp).Offset(2).Value = "Thanks"
    wsTemp.Range("A1:D1").Merge
    wsTemp.Range("A3:D3").Merge
    wsTemp.Cells.EntireColumn.AutoFit
    wsTemp.Range("A:D").ColumnWidth = 18
    wsTemp.Range("A1:D3").WrapText = True
    wsTemp.Range("A1:D3").Font.Bold = False

    'Publish the sheet to a htm file
    With wbTemp.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=wsTemp.Name, _
         Source:=wsTemp.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 wbTemp
    wbTemp.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set wbTemp = Nothing
End Function

Public Sub TOGGLEEVENTS(blnState As Boolean)
    Application.DisplayAlerts = blnState
    Application.EnableEvents = blnState
    Application.ScreenUpdating = blnState
    If blnState Then Application.CutCopyMode = False
    If blnState Then Application.StatusBar = False
End Sub

Open in new window


Regards,
Zack
0
 
codevuAuthor Commented:
Hi Zack,

Thanks for this - I made the changes and have tried this on my own sheet. I appreciate my sheet may be different to the sample but I get an error when running it.

'AutoFilter method of Range class failed' on line 51.

rData.AutoFilter 50, "Yes" - my sheet has a formula which generates "Yes" or "No" based on criteria - is there any reason why I might get an error? Cell formatting? (I've tried general and text)

Any support is much appreciated.
0
 
Zack BarresseCEOCommented:
You'll usually see that error with AutoFilter if the Field value isn't set right.  You're setting it at 50.  So if the range started in column A, then 50 would be column AX - and it would need to be included in your range, so it would be A:AX.  In this case, our code for setting the range is this...
Set rData = WS.Range("A1:G" & WS.Cells(WS.Rows.Count, 1).End(xlUp).Row)

Open in new window

This goes from A1 through column G, the last row being that last row in column A with data found in it.  So it's A1:Gx, where the 'x' is the last (dynamic) row.  You would need to change the G to AX, assuming that's your range.  If your data range didn't start with A, you would need to adjust accordingly.

If you need help with it, just let us know what you're setting the range to and what column you want to filter.  Counting from the left, the first column in your range is going to be 'Field' 1 of the syntax.

Zack
0

Featured Post

Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

  • 5
  • 4
Tackle projects and never again get stuck behind a technical roadblock.
Join Now