Question

我正在管理在发送项目状态报告时使用的Excel中的电子邮件地址列表。它是一个包含几行混乱行的列表，为了简化维护，有一列包含组名。由于此人属于多个组，因此在多个地方都有一些电子邮件地址。

示例： John属于“销售”和“项目”组。

当我们使用电子邮件地址列表时，我们需要删除重复项，以避免同一个人多次收到电子邮件。因此，我们将整个列与所有电子邮件地址一起复制，将其粘贴到新的工作表中，删除重复项，然后再次复制电子邮件地址。现在我们转到“收件人”字段中的Outlook和PASTE，然后按ctrl-k使Outlook评估地址。此后，有必要返回excel文件并删除我们在删除重复项的地方创建的新工作表。

我想使它自动执行，所以我创建了下面的脚本，该脚本很好用，但是当我删除临时工作表（在其中进行了COPY操作）时，剪贴板被清空了。如果我在代码末尾注释掉行ws_dest.Delete，它将起作用。

即使删除工作表后，如何以仍保留在剪贴板上的方式复制到剪贴板？还是我的问题有其他解决方案？

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

Answer 1

在这里，我将电子邮件添加到ArrayList中，以删除重复项，加入列表，然后将其添加到剪贴板。

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

Answer 2

感谢cybernautic.nomad您的想法，可以直接创建eamil。

感谢TinMan展示了如何使用ArrayListr和Join。这使我的代码更加简单。

这是我现在使用的代码。仍然很大，但是效果很好。

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 Settings\test.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

Answer 3

首先，您要远离.Select和.Activate

您的代码还应该在复制整个列时找到最后使用的行

要查找最后一行，请使用：（您可以使用喜欢的命名约定，在本示例中，我使用“ LastRow_Unique”）

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

然后将其细分为公式，以将一行唯一的值复制/粘贴到一行中。根据需要更改单元格引用“ D1”和“ A1”。

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

一旦您复制/粘贴了唯一值，就可以重新评估最后一行并将该范围复制到其他地方，

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

取消选择范围后，将复制的范围保留在剪贴板中

3 个答案: