Wsrtjtyk

I am managing a list of email adresses in Excel that we are using when sending out status reports for a project. It is a list with several hundered rows, and to simplify the maintenance, there is one column containing groupname. There are some email addresses in several places since the person belongs to several groups.

Example:
John is both in the group "Sales" and "Project group".

When we use the list of email addresses we need to remove duplicates to avoid that the same person get the email several times. So we COPY the whole column with all email addresses, paste it in a new sheet, remove duplicates and then COPY the email adresses again. Now we go to Outlook and PASTE in the To-field and pressing ctrl-k to make Outlook evaluate the adresses.
After this it is necessary to go back to the excel file and delete that new sheet we created where we deleted duplicates.

I would like to make this automatic, so I created the below script that works well, except that when I delete the temporary sheet (in which I made COPY), the clipboard is emptied. If I comment out the line ws_dest.Delete at the end of the code it works.

How can I make the COPY to clipboard in a way that it stays there even after the sheet is deleted?
Or is there any other solution to my problem?

Sub CopyEmailAdresses()

'----------------------------------

'Purpose    To make it simple for the user to grab the list of email adresses

'           without getting any duplicates, so that they can paste the adresses

'           in their email client.

'           Copy the column with email adresses (row 1 is header) and paste in

'           new sheet, remove duplicates and header and copy the row to clipboard.

'           Then delete the temporary sheet.

'------------------------------------

Dim ws_source As Worksheet

Dim ws_dest As Worksheet

    'Remember where we are

    Set ws_source = ActiveSheet

    'Create an empty sheet which will be used for "cleaning" the email adresses

    'and copy the column with amll email adresses

    Set ws_dest = Sheets.Add(After:=ActiveSheet)

    ws_source.Range("D:D").Copy Destination:=ws_dest.Range("A1")

    'Remove duplicates and the header

    ws_dest.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlYes

    ws_dest.Rows("1:1").Delete Shift:=xlUp

    'Copy to clipboard

    ws_dest.Range("A:A").Copy

    'Go back to the source sheet and delete the temporary sheet

    ws_source.Activate

    Application.DisplayAlerts = False    'We dont want the confirmation popup

    ws_dest.Delete

    Application.DisplayAlerts = True

End Sub

Thanks cybernautic.nomad for your idea to look into creating the eamil directly.

Thanks TinMan for showing how to use the ArrayListr and Join. That made my code much simpler.

Here is the code I use now. Still it pretty big, but it works fine.

Option Explicit



Function CreateEmail()

' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, Outlook 2010.

' This example sends the last saved version of the Activeworkbook object .

Dim OutApp As Object

Dim OutMail As Object

Dim emailadr As String

Dim ws As Worksheet

Dim EMAIL_col As Long

Dim HEADER_row As Long

Dim list As Variant

Dim r As Long



    Set OutApp = CreateObject("Outlook.Application")

    Set OutMail = OutApp.CreateItem(0)



    Set ws = ActiveSheet        'emails are in this sheet

    EMAIL_col = 4               'emails are in this column

    HEADER_row = 1              'Header is on this row

    Set list = CreateObject("System.Collections.ArrayList")



    r = LastNonEmptyRow(ws.Cells(1, EMAIL_col))

    Do While r > HEADER_row

        emailadr = Trim(ws.Cells(r, EMAIL_col).Value)

        If InStr(emailadr, "@") = 0 Then list.Add emailadr

        r = r - 1

    Loop



    With OutMail

        .To = Join(list.toarray, ";")

        '.CC = "" remove comma and use this if you want to cc anyone, can be string or variable

        '.BCC = "" remove comma and use this if you want to cc anyone, can be string or variable

        .Subject = "DORS"

        .HTMLBody = "<HTML><BODY><Font Face=Verdana><p>Email prepared.<br>Click on one of the email adresses and press CTRL_k to tell Outlook to evaluate them.</p></font></BODY></HTML>"

        '.attachments.Remove 1

        '.attachments.Add "C:Documents and Settingstest.xlsx"

        .Display

       ' .Send

    End With



    Set OutMail = Nothing

    Set OutApp = Nothing





End Function





Function LastNonEmptyRow(rng As Range) As Long

    If rng.Parent.Cells(Rows.Count, rng.Column) <> "" Then

        LastNonEmptyRow = rng.Parent.Cells(Rows.Count, rng.Column).Row

    Else

        LastNonEmptyRow = rng.Parent.Cells(Rows.Count, rng.Column).End(xlUp).Row

    End If

End Function

Here I add emails to an ArrayList to remove the duplicates, join the list and then add it to the clipboard.

Sub CopyEmailAdresses()

    Const EmailDelimiter As String = ";"



    Dim item As Variant, List As Object

    Set List = CreateObject("System.Collections.ArrayList")



    With Worksheets("Sheet1")

        For Each item In .Range("D2", .Cells(.Rows.Count, "D").End(xlUp))

            If item <> "" And Not List.Contains(item) Then List.Add item

        Next

    End With



    If List.Count = 0 Then Exit Sub

    With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")

        .SetText Join(List.ToArray, EmailDelimiter)

        .PutInClipboard

    End With

End Sub

Firstly you want to stay away from .Select and .Activate

Your code should also find the last used row as you are copying the ENTIRE column

To find the last row use: (you can use what ever naming convention you like, In this example I use "LastRow_Unique")

LastRow_Unique = ws_source.Range("D" & Rows.Count).End(xlUp).Row

Then sub that into a formula to copy/paste the unique valuse all in one line. The change the cell refernce 'D1' and 'A1' as required.

ws_source.Range("D1:D" & LastRow_Unique).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws_dest.Range("A1"), Unique:=True

Once you have the unique values copied/paste, you can then re-evaluate the last row and have that range copied else where:

LastRow_Unique2 = ws_dest.Range("A" & Rows.Count).End(xlUp).Row