Consulting

Results 1 to 2 of 2

Thread: Adding a sum total to a Ron de Bruin VBA to email workbooks

  1. #1
    VBAX Regular
    Joined
    Feb 2018
    Posts
    70
    Location

    Adding a sum total to a Ron de Bruin VBA to email workbooks

    Hi, I am using a formula by Ron de Bruin, which emails an attachment to everyone named in column A. It copies the data in A to H and emails that data in an excel attachment to the people in columns A.
    I am wanting it to add the totals values of column E and F to each of the new workbooks it creates. Can anyone help me with this? I've added the VBA code and function below (question also posted in the Mrexcel.com forum)

    Many thanks

    HTML Code:
    Sub Send_Row_Or_Rows_1()
    'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    'Don't forget to copy the function RangetoHTML in the module.
    'Working in Excel 2000-2016
        Dim OutApp As Object
        Dim OutMail As Object
        Dim rng As Range
        Dim Ash As Worksheet
        Dim Cws As Worksheet
        Dim Rcount As Long
        Dim Rnum As Long
        Dim FilterRange As Range
        Dim FieldNum As Integer
        Dim mailAddress As String
    
        On Error GoTo cleanup
        Set OutApp = CreateObject("Outlook.Application")
    
        With Application
            .EnableEvents = False
            .ScreenUpdating = False
        End With
    
        'Set filter sheet, you can also use Sheets("MySheet")
        Set Ash = ActiveSheet
    
        'Set filter range and filter column (Column with names)
        Set FilterRange = Ash.Range("A1:H" & Ash.Rows.Count)
        FieldNum = 1    'Filter column = A because the filter range start in A
    
        'Add a worksheet for the unique list and copy the unique list in A1
        Set Cws = Worksheets.Add
        FilterRange.Columns(FieldNum).AdvancedFilter _
                Action:=xlFilterCopy, _
                CopyToRange:=Cws.Range("A1"), _
                CriteriaRange:="", Unique:=True
    
        'Count of the unique values + the header cell
        Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))
    
        'If there are unique values start the loop
        If Rcount >= 2 Then
            For Rnum = 2 To Rcount
    
                'Filter the FilterRange on the FieldNum column
                FilterRange.AutoFilter Field:=FieldNum, _
                                       Criteria1:=Cws.Cells(Rnum, 1).Value
    
                'Look for the mail address in the MailInfo worksheet
                mailAddress = ""
                On Error Resume Next
                mailAddress = Application.WorksheetFunction. _
                              VLookup(Cws.Cells(Rnum, 1).Value, _
                                    Worksheets("Mailinfo").Range("A1:B" & _
                                    Worksheets("Mailinfo").Rows.Count), 2, False)
                On Error GoTo 0
    
                If mailAddress <> "" Then
                    With Ash.AutoFilter.Range
                        On Error Resume Next
                        Set rng = .SpecialCells(xlCellTypeVisible)
                        On Error GoTo 0
                    End With
    
                    Set OutMail = OutApp.CreateItem(0)
    
                    On Error Resume Next
                    With OutMail
                        .to = mailAddress
                        .Subject = "Test mail"
                        .HTMLBody = RangetoHTML(rng)
                        .Display  'Or use Send
                    End With
                    On Error GoTo 0
    
                    Set OutMail = Nothing
                End If
    
                'Close AutoFilter
                Ash.AutoFilterMode = False
    
            Next Rnum
        End If
    
    cleanup:
        Set OutApp = Nothing
        Application.DisplayAlerts = False
        Cws.Delete
        Application.DisplayAlerts = True
    
        With Application
            .EnableEvents = True
            .ScreenUpdating = True
        End With
    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

  2. #2
    VBAX Newbie
    Joined
    Sep 2009
    Posts
    1
    Location

    add 2 table code in .HTMLBODY

    add table in .HTMLBODY
    see sample below

    'Look for the mail address in the MailInfo worksheet
                mailAddress = ""
                On Error Resume Next
                          mailAddress = Application.WorksheetFunction.VLookup(Cws.Cells(Rnum, 1).Value, Worksheets("Mailinfo").Range("A1:Z" & Worksheets("Mailinfo").Rows.Count), 2, False)
                ccMailAddress = Application.WorksheetFunction.VLookup(Cws.Cells(Rnum, 1).Value, Worksheets("Mailinfo").Range("A1:Z" & Worksheets("Mailinfo").Rows.Count), 3, False)
                strSubject = Application.WorksheetFunction.VLookup(Cws.Cells(Rnum, 1).Value, Worksheets("Mailinfo").Range("A1:Z" & Worksheets("Mailinfo").Rows.Count), 4, False)
                strAccount = Application.WorksheetFunction.VLookup(Cws.Cells(Rnum, 1).Value, Worksheets("Mailinfo").Range("A1:Z" & Worksheets("Mailinfo").Rows.Count), 1, False)
             
      On Error Resume Next
                If mailAddress <> "" Then
                    With Ash.AutoFilter.Range
                        On Error Resume Next
                        Set rng = .SpecialCells(xlCellTypeVisible)
                        On Error GoTo 0
                    End With
                        Set OutMail = OutApp.CreateItem(0)
                        Set myOlApp = CreateObject("Outlook.Application")
                        Set myMail = myOlApp.CreateItem(olMailItem)
                   On Error Resume Next
    
        Dim CountAInv As Integer
        Dim CountCash As Integer
        Dim CountAcct As Integer
        Dim CountBR As Integer
        Dim strCsh As String
        Dim strAct As String
        Dim strNoInv As String
        Dim strBR As String
        
         strCsh = "DUTYTHCSH"
         strAct = "569*"
         strNoInv = ""
         strBR = "BRKR"
    
         'vlookup data between excel & body message for sum total in body
    
         If strAccount = strSubject Then
          SumOfD = WorksheetFunction.SumIf(Range("Sheet1!A5:A" & LastRow), strAccount, Range("Sheet1!E5:E" & LastRow))
          End If
    
    
         If strAccount = strSubject Then
          CountAInv = WorksheetFunction.CountIfs(Range("Sheet1!A5:A" & LastRow), strAccount, Range("Sheet1!B5:B" & LastRow))
          End If
       
         If strAccount = strSubject And strCsh = "DUTYTHCSH" Then
          CountCash = WorksheetFunction.CountIfs(Range("Sheet1!A5:A" & LastRow), strAccount, Range("Sheet1!D5:D" & LastRow), strCsh)
       End If
       
         If strAccount = strSubject And strAct = "569*" Then
          CountAcct = WorksheetFunction.CountIfs(Range("Sheet1!A5:A" & LastRow), strAccount, Range("Sheet1!D5:D" & LastRow), strAct)
    End If
      
         If strAccount = strSubject And strNoInv = "" Then
          CountNoInv = WorksheetFunction.CountIfs(Range("Sheet1!A5:A" & LastRow), strAccount, Range("Sheet1!D5:D" & LastRow), strNoInv)
    End If
      
           If strAccount = strSubject And strBR = "BRKR" Then
          CountBR = WorksheetFunction.CountIfs(Range("Sheet1!A5:A" & LastRow), strAccount, Range("Sheet1!I5:I" & LastRow), strBR)
    End If
    
    With OutMail
                        .To = mailAddress
                        .CC = ccMailAddress
                        .Subject = ""
                          .HTMLBody = "<table width=""1100"" border=1 black;>" & RangetoHTML(rng) & _
                                            " </tr></table>" & _
                                            "<p><table style= background-color:#FFCC00; width=""1270"" border=1 black;><tr><td width=""900"">Total document  &nbsp; &nbsp;                                                    &nbsp;&nbsp; &nbsp; Cash =" & CountCash & " &nbsp; &nbsp; &nbsp;&nbsp; &nbsp;Credit = " & CountAcct & " &nbsp; &nbsp; &nbsp;&nbsp;                                              &nbsp;NoInvoice  = " & CountNoInv & "&nbsp; &nbsp; &nbsp;&nbsp; &nbsp;Broker = " & CountBR & "</td>" & "<td width=""400""                                            align='center'><b>" & CountAInv & "</b></td></tr></table>

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •