Макрос для копирования ячеек из одного столбца в буфер обмена, если другой столбец равен значению

Question

У меня большой список контактов, и я хочу макрос, который копирует их адреса электронной почты, столбец J, в буфер обмена, если они были выбраны, = "a" в столбце C.

Контактсписок постоянно редактируется, некоторые удаляются, другие добавляются.Я назвал строку выше и ниже информации о данных для ссылки на функцию, которая хорошо работала с моими другими макросами.

Sub CopySelected()
Dim oData As New DataObject 
oData.SetText Text:=Empty 'Clear
oData.PutInClipboard
With Worksheets("Master")
    For Each Cell In Range(.Cells(.Range("BorderFirstRow").Row + 1, "C"), _
                .Cells(.Range("BorderLastRow").Row - 1, "C"))
        If Cell.Value = "a" Then

                .PutInClipboard
        End If
    End With
End Sub

Что мне нужно сделать, чтобы макрос скопировал адрес электронной почты, столбецJ, если столбец C = "A"?

Answer 1

Это фиктивный рабочий лист с фиктивными данными.Надеюсь, что это похоже на ваше: Приведенный ниже код не дал мне ошибок:

Sub CopyToClip()

Dim ClipB As New DataObject
Dim RangeToConsider As Range
Dim strAddresses As String

    ' set the range
    ' here just set the relevant range from the C column
        Set RangeToConsider = Range("E4:E7") ' in my case!
For Each cell In RangeToConsider
    If cell.Value = "a" Or cell.Value = "A" Then
        If Not (Trim(cell.Offset(0, -2).Value) = "") Then
           strAddresses = strAddresses & "; " & cell.Offset(0, -2).Value
        end if
    End If
Next
strAddresses = Mid(strAddresses, 2) ' delete the first semicolon
strAddresses = strAddresses & ";" ' add a semicolon at the end
strAddresses = Trim(strAddresses) ' delete spaces if any
Debug.Print strAddresses
ClipB.SetText strAddresses
ClipB.PutInClipboard
Debug.Print ClipB.GetText()
End Sub

Итак, после запуска процедуры я могу вставить 'Имя;AnotherName; '