Copy, combine and delete duplicate copies

[ABabeNChrist]

I would like to combine emails address from sheet1, column A and sheet2 column A and paste on sheet3 column A and delete duplicate copies.

[HansV]

Try this (substituting the actual names of the sheets):

Code: Select all

Sub CopyUniqueAddresses()
  Dim wsh As Worksheet

  Dim col As New Collection
  Dim r As Long
  Dim m As Long

  Set wsh = Worksheets("Sheet1")
  m = wsh.Cells(wsh.Rows.Count, 1).End(xlUp).Row
  For r = 2 To m
    On Error Resume Next
    col.Add wsh.Cells(r, 1), wsh.Cells(r, 1)
    On Error GoTo 0
  Next r

  Set wsh = Worksheets("Sheet2")
  m = wsh.Cells(wsh.Rows.Count, 1).End(xlUp).Row
  For r = 2 To m
    On Error Resume Next
    col.Add wsh.Cells(r, 1), wsh.Cells(r, 1)
    On Error GoTo 0
  Next r

  Set wsh = Worksheets("Sheet3")
  wsh.Columns(1).ClearContents
  wsh.Cells(1, 1) = "E-mail Address"
  wsh.Cells(1, 1).Font.Bold = True
  For r = 1 To col.Count
    wsh.Cells(r + 1, 1) = col(r)
  Next r
End Sub

I have assumed that the e-mail addresses start in row 2.

[ABabeNChrist]

Thank you Hans
I have another little twist to this.
Is it possible to have only the email addresses from sheet1 to be a red font once applied to sheet3. The reason being is sheet1 holds my previous used email address and sheet2 holds my most current updated email addresses. By using a red font it will give me a better clue as to how many new account email addresses I have.

[HansV]

(For the future: please state your requirements outright instead of modifying them when you already have a reply. The reply could be invalidated by the new requirements - as in this thread. Thank you.)

Are the e-mail addresses on Sheet1 guaranteed to be unique?
Are the e-mail addresses on Sheet2 guaranteed to be unique?

[ABabeNChrist]

I apologize and I do understand what you mean I should of thought it through more carefully before posting.
As to
Are the e-mail addresses on Sheet1 guaranteed to be unique?
Are the e-mail addresses on Sheet2 guaranteed to be unique?
I do not fully understand what you mean by unique

[HansV]

Could there be duplicate e-mail addresses within column A on Sheet1?

Same question for Sheet2 (by itself).

[ABabeNChrist]

No

[HansV]

Here is a modified version of the macro:

Code: Select all

Sub CopyUniqueAddresses()
  Dim wsh As Worksheet
  Dim wsh3 As Worksheet
  Dim rng As Range
  Dim r As Long
  Dim m As Long
  Dim n As Long
  Dim s As Long

  Set wsh3 = Worksheets("Sheet3")
  wsh3.Columns(1).Clear
  With wsh3.Cells(1, 1)
    .Value = "E-mail Address"
    .Font.Bold = True
  End With

  Set wsh = Worksheets("Sheet1")
  m = wsh.Cells(wsh.Rows.Count, 1).End(xlUp).Row
  With wsh3.Range("A2:A" & m)
    .Value = wsh.Range("A2:A" & m).Value
    .Font.Color = vbRed
  End With

  s = m
  Set wsh = Worksheets("Sheet2")
  n = wsh.Cells(wsh.Rows.Count, 1).End(xlUp).Row
  For r = 2 To n
    Set rng = wsh3.Range("A2:A" & m).Find(What:=wsh.Cells(r, 1).Value, _
      LookAt:=xlWhole, MatchCase:=False)
    If rng Is Nothing Then
      s = s + 1
      wsh3.Cells(s, 1).Value = wsh.Cells(r, 1).Value
    End If
  Next r
End Sub

[ABabeNChrist]

Perfecto as always thank you Hans