Copy and paste Unique values only

Chewyhairball

Active Member
Joined
Nov 30, 2017
Messages
312
Office Version
  1. 365
Platform
  1. Windows
Hi

I will be selecting data from a tab using Carl-A. I will then paste this data into a new sheet.
The first column is ID numbers, some of which will show up multiple times.

What I would like is to copy all the data but only paste the rows with Unique values in the first column.

So for example if the ID 1234 appears more than once then all instances do not get pasted into the new sheet.

thanks

rory
 

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN
Same end result but different way of getting there. Depending on which sheet I will use each way will serve a purpose.

one is to remove duplicates during the pasting process and the other is to find duplicates already in the column and remove them.

Why? Do you have a solution for either.
 
Upvote 0
Put this code in a specific tab workssheet module
VBA Code:
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i&, dic As Object, key, rng
Set dic = CreateObject("Scripting.dictionary")
Application.ScreenUpdating = False
If Selection.Rows.Count > 1 Then
    rng = Selection.Value
    Range("A1").Select
    Worksheets.Add
    With ActiveSheet
        .Range("A1").Resize(UBound(rng, 1), UBound(rng, 2)).Value = rng
        For i = 1 To UBound(rng, 1)
            If Not dic.exists(rng(i, 1)) And Not IsEmpty(rng(i, 1)) Then
                dic.Add rng(i, 1), 1
            Else
                dic(rng(i, 1)) = dic(rng(i, 1)) + 1
            End If
        Next
        For i = 1 To UBound(rng, 1)
            For Each key In dic.keys
                If rng(i, 1) = key And dic(key) = 1 Then rng(i, 1) = "#N/A"
            Next
        Next
       .Range("A1").Resize(UBound(rng, 1), UBound(rng, 2)).Value = rng
       .Range("A1").Resize(UBound(rng, 1), UBound(rng, 2)).SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Delete
    End With
End If
Application.ScreenUpdating = True
End Sub
 
Upvote 0
Same end result but different way of getting there. Depending on which sheet I will use each way will serve a purpose.

one is to remove duplicates during the pasting process and the other is to find duplicates already in the column and remove them.

Why? Do you have a solution for either.
OK, so two different ways of coming at the same issue.
Just wanted to make sure that we didn't duplicate questions, as per rule 12 here: Message Board Rules

I have some ideas on the other one, but before I do that, did bebo02199's solution work for you?
If so, then I am guessing that you probably don't need the other one.
 
Upvote 0
I note that the OP has 'Liked' post #4 here and post #2 in that other thread, but has not actually indicated whether either has answered the question asked in the relevant thread so we have no idea whether the following has been answered. :(
Do you have a solution for either.
 
Upvote 0
Jees guys chill. Give me a chance to use them. I liked the posts to show I appreciate you sending me potential,solutions but some times life happens and other things come up. Not been at my PC since yesterday afternoon so as soon as I get a chance I will test them and let you know how they worked.
Didn’t realise there was a timescale to testing and then replying.
Also, isn’t the tick supposed to indicate that a solution was found so given that I haven’t ticked that then obviously I haven’t checked it yet.
that’s the rules isn’t it?
 
Last edited:
Upvote 0
OK, so two different ways of coming at the same issue.
Just wanted to make sure that we didn't duplicate questions, as per rule 12 here: Message Board Rules

I have some ideas on the other one, but before I do that, did bebo02199's solution work for you?
If so, then I am guessing that you probably don't need the other one.
Hi Joe. I haven’t checked bebo’s yet. Something came up at home so not had a chance. As soon as I do I will let you know. Thanks.
 
Upvote 0
Put this code in a specific tab workssheet module
VBA Code:
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i&, dic As Object, key, rng
Set dic = CreateObject("Scripting.dictionary")
Application.ScreenUpdating = False
If Selection.Rows.Count > 1 Then
    rng = Selection.Value
    Range("A1").Select
    Worksheets.Add
    With ActiveSheet
        .Range("A1").Resize(UBound(rng, 1), UBound(rng, 2)).Value = rng
        For i = 1 To UBound(rng, 1)
            If Not dic.exists(rng(i, 1)) And Not IsEmpty(rng(i, 1)) Then
                dic.Add rng(i, 1), 1
            Else
                dic(rng(i, 1)) = dic(rng(i, 1)) + 1
            End If
        Next
        For i = 1 To UBound(rng, 1)
            For Each key In dic.keys
                If rng(i, 1) = key And dic(key) = 1 Then rng(i, 1) = "#N/A"
            Next
        Next
       .Range("A1").Resize(UBound(rng, 1), UBound(rng, 2)).Value = rng
       .Range("A1").Resize(UBound(rng, 1), UBound(rng, 2)).SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Delete
    End With
End If
Application.ScreenUpdating = True
End Sub
Hi bebo, I have not had a chance to check your code yet but as soon as I do I will let you know. I appreciate the speedy response to my query so I will try and have a look and reply to you when I am back at my PC. Thanks. Rory
 
Upvote 0
Didn’t realise there was a timescale to testing and then replying.
There isn't, but given that we could see that you had visited since suggestions were made it does make helpers wonder. A quick note like you did in post #3 of the other thread wouldn't take a lot longer than the Like and would clarify where you are at.


Also, isn’t the tick supposed to indicate that a solution was found so given that I haven’t ticked that then obviously I haven’t checked it yet.
Given that more than half the threads that get solved do not ever get a tick, that is an unreliable indicator. In any case, no tick actually means no solution has been accepted, it does not suggest anything about whether suggestions have been tried.

In any case, we now know where you are at, thanks.
 
Upvote 0

Forum statistics

Threads
1,213,535
Messages
6,114,194
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top