VBA Help

[VbaHell]

Hello One and All

I have a workbook named Suppliers with columns A to M and multiple rows
Column a has the suppliers Email address which drops in from a Vlookup driven by a VBA Macro.

How can I then send all the rows to each supplier with Microsoft Office Outlook 2003 with a standard message and Title.

 

[Zack Barresse]

Hello there,

How do you correlate the supplier with their email address? Do you have a list somewhere? Do you have Outlook Redemption or ClickYes?

 

[VbaHell]

Hello Zack

On Tab 2 of the same workbook is a list of suppliers account numbers in Column A and the Email address in column B.
I perform a Vlookup matching the account number on the first Tab in column B and then drop in the Email address in column A.

I am using Outlook 2003 And I think the answer to your question is the Yes/No

 

[Zack Barresse]

Ok, I think I understand now. This should work for you. It assumes you will put the code in a standard module of that workbook (hence the "ThisWorkbook" line of code)...

Option Explicit

'References set to:
'   Microsoft Outlook 14.0 Object Library
'   Microsoft Scripting Runtime

Sub SendOutlookEmailsToSuppliers()

    Dim DIC As New Scripting.Dictionary, dicKey As Variant
    Dim OL As Outlook.Application, olMail As Outlook.MailItem
    Dim WS As Worksheet, c As Range, rFilter As Range
    Dim rLook As Range, rWhole  As Range
    Dim bOLOpen As Boolean, iLastRow As Long
    
    Const sSTAMPTEXT As String = "Type whatever you want below your range in the message here."
    
    On Error Resume Next
    Set OL = GetObject(, "Outlook.Application")
    bOLOpen = True
    If OL Is Nothing Then
        Set OL = CreateObject("Outlook.Application")
        bOLOpen = False
    End If
    
    Set WS = ThisWorkbook.Worksheets("Suppliers")
    iLastRow = WS.Cells.Find(What:="*", After:=WS.Cells(1, 1), LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set rWhole = WS.Range("A1:M" & iLastRow)
    Set rFilter = WS.Range("A2:M" & iLastRow)
    
    For Each c In WS.Range("A2:A" & iLastRow)
        If DIC.Exists(c.Value) = False Then
            DIC.Add c.Value, c.Value
        End If
    Next c
    
    On Error Resume Next
    For Each dicKey In DIC.Items
    
        rWhole.AutoFilter 1, dicKey
        
        If rFilter.SpecialCells(xlCellTypeVisible).Count > 0 Then
            Set olMail = OL.CreateItem(olMailItem)
            olMail.To = dicKey
            olMail.Subject = "SUBJECT"
            olMail.HTMLBody = RangetoHTML(rFilter.SpecialCells(xlCellTypeVisible)) & vbNewLine & vbNewLine & sSTAMPTEXT
            olMail.Display
        End If
        
        WS.AutoFilterMode = False
        
    Next dicKey
    
    If bOLOpen = False Then OL.Quit
    
End Sub

Function RangetoHTML(rng As Range)
    ' Changed 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 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

It utilizes a function from Ron de Bruin (website found here: http://www.rondebruin.nl/mail/folder3/mail4.htm) which I have included. This is an all-in-one code and works for me in testing. It will display all emails, not send them. If you wish to send them, it would take more coding and my preference is to use ClickYes, a free download/install. Also please note the comments at the top, as it takes two references. You don't have to have them and we can use early binding, but the code would need to be amended. To add the references listed, in your VBE go to Tools | References, check them and click Ok. You must have the file selected in your Project Explorer (Ctrl + R) as they attach per file.

HTH

 

[VbaHell]

Really appreciate your help on this
I will give this a try

Many Thanks