Copy, combine and delete duplicate copies
-
- SilverLounger
- Posts: 1868
- Joined: 25 Jan 2010, 14:00
- Location: Conroe, Texas
Copy, combine and delete duplicate copies
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.
-
- Administrator
- Posts: 78535
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
Re: Copy, combine and delete duplicate copies
Try this (substituting the actual names of the sheets):
I have assumed that the e-mail addresses start in row 2.
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
Best wishes,
Hans
Hans
-
- SilverLounger
- Posts: 1868
- Joined: 25 Jan 2010, 14:00
- Location: Conroe, Texas
Re: Copy, combine and delete duplicate copies
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.
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.
-
- Administrator
- Posts: 78535
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
Re: Copy, combine and delete duplicate copies
(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?
Are the e-mail addresses on Sheet1 guaranteed to be unique?
Are the e-mail addresses on Sheet2 guaranteed to be unique?
Best wishes,
Hans
Hans
-
- SilverLounger
- Posts: 1868
- Joined: 25 Jan 2010, 14:00
- Location: Conroe, Texas
Re: Copy, combine and delete duplicate copies
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
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
-
- Administrator
- Posts: 78535
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
Re: Copy, combine and delete duplicate copies
Could there be duplicate e-mail addresses within column A on Sheet1?
Same question for Sheet2 (by itself).
Same question for Sheet2 (by itself).
Best wishes,
Hans
Hans
-
- SilverLounger
- Posts: 1868
- Joined: 25 Jan 2010, 14:00
- Location: Conroe, Texas
-
- Administrator
- Posts: 78535
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
Re: Copy, combine and delete duplicate copies
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
Best wishes,
Hans
Hans
-
- SilverLounger
- Posts: 1868
- Joined: 25 Jan 2010, 14:00
- Location: Conroe, Texas
Re: Copy, combine and delete duplicate copies
Perfecto as always thank you Hans