Сохранить скопированный диапазон в буфере обмена после отмены выбора диапазона

Question

Я управляю списком адресов электронной почты в Excel, которые мы используем при отправке отчетов о состоянии проекта.Это список с несколькими упорядоченными строками, и для упрощения обслуживания есть один столбец, содержащий имя группы.Есть несколько адресов электронной почты в нескольких местах, так как человек принадлежит к нескольким группам.

Пример: Джон находится в группе «Продажи» и «Группа проектов».

Когда мы используем список адресов электронной почты, нам нужно удалить дубликаты, чтобы один и тот же человек не мог получить письмо несколько раз.Таким образом, мы копируем весь столбец со всеми адресами электронной почты, вставляем его в новый лист, удаляем дубликаты, а затем снова копируем адреса электронной почты.Теперь мы переходим в Outlook и PASTE в поле To и нажимаем 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

Затем подставьте это в формулу, чтобы скопировать / вставить уникальное значение Valuse в одну строку.При необходимости измените ссылку на ячейку '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