+ Reply to Thread
Results 1 to 2 of 2

Macro to remove duplicates and send email?

Hybrid View

Milet Macro to remove duplicates... 11-17-2011, 04:08 PM
Milet Re: Macro to remove... 11-17-2011, 04:55 PM
  1. #1
    Registered User
    Join Date
    09-05-2011
    Location
    New Zealand
    MS-Off Ver
    Excel 2003
    Posts
    10

    Question Macro to remove duplicates and send email?

    Hi Guys

    I work for an online retail store and have a spreadsheet that I use to order stock in from other stores and suppliers. I bastardised a macro I found online to email a selection of cells.

    These are the steps that the macro does:
    Copy the range and create a new workbook to past the data in
    Publish the sheet to a htm file
    Read all data from the htm file into RangetoHTML
    Close TempWB
    Delete the htm file we used in this function


    I also need it to remove duplicates before it sends the email but I'm not quite sure how to do this, can anyone help me?


    Sub Mail_Selection_Range_Outlook_Body_INC()
    ' Don't forget to copy the function RangetoHTML in the module.
    ' Working in Office 2000-2010
        Dim rng As Range
        Dim OutApp As Object
        Dim OutMail As Object
        Dim StrBody As String
        Dim SigString As String
        Dim Signature As String
      
         StrBody = "<font size=""3"" face=""Calibri"">" & _
                      "Hi there,<br><br>" & _
    "Please find the attached Order, can you please send me an Order Confirmation and let me know if something is not available. Can I also get this shipped same day delivery or here by the next working day.<br><br>" & _
                      "Please note that since we need these products as soon as possible we do no wish to have any unavailable products placed on back order, we will source them from another Bivouac Outdoor branch. So can you please cancel any back ordered products.<br><br>" & _
                      "<br>Kind Regards</font>"
    
    
    
        Set rng = Nothing
        On Error Resume Next
        'Only the visible cells in the selection
        Set rng = Selection.SpecialCells(xlCellTypeVisible)
        'You can also use a range if you want
        'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
    
        If rng Is Nothing Then
            MsgBox "The selection is not a range or the sheet is protected" & _
                   vbNewLine & "please correct and try again.", vbOKOnly
            Exit Sub
        End If
    
        With Application
            .EnableEvents = False
            .ScreenUpdating = False
        End With
    
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
    
        SigString = "C:\Documents and Settings\Anita\Application Data\Microsoft\Signatures\Michael.htm"
                    
        If Dir(SigString) <> "" Then
            Signature = GetBoiler(SigString)
        Else
            Signature = ""
        End If
    
        On Error Resume Next
        With OutMail
            .To = "orders@supplier.com"
            .CC = ""
            .BCC = ""
            .Subject = " (Web) Order" & " " & Range("C2").Text
            .HTMLBody = StrBody & RangetoHTML(rng) & Signature
            .Display   'or use .Send
        End With
        On Error GoTo 0
    
        With Application
            .EnableEvents = True
            .ScreenUpdating = True
        End With
    
        Set OutMail = Nothing
        Set OutApp = Nothing
    End Sub
    
    Function GetBoiler(ByVal sFile As String) As String
    '**** Kusleika
        Dim fso As Object
        Dim ts As Object
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
        GetBoiler = ts.readall
        ts.Close
    End Function
    
    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

  2. #2
    Registered User
    Join Date
    09-05-2011
    Location
    New Zealand
    MS-Off Ver
    Excel 2003
    Posts
    10

    Re: Macro to remove duplicates and send email?

    I might have just solved it myself. Can someone please let me know if you see any problems with this? It seems to work for now...

    I just added it in to Function RangetoHTML(rng As Range) after the section 'Copy the range and create a new workbook to past the data in

        'Removes Duplicates
        Dim x               As Long
        Dim LastRow         As Long
         
        LastRow = Range("A65536").End(xlUp).Row
        For x = LastRow To 1 Step -1
            If Application.WorksheetFunction.CountIf(Range("A1:A" & x), Range("A" & x).Text) > 1 Then
                Range("A" & x).EntireRow.Delete
            End If
        Next x

+ Reply to Thread

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Bookmarks

Posting Permissions

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

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1