Copy and Paste without Duplicate values from table to another table on same Sheet

[aroig07]

Hi Everyone !!

I have written a code to copy values from one column and then pasting without duplicate values on another column in the same sheet. I am having issues because instead of deleting the duplicate values only its is removing the entire row where those duplicate entries are found. I am basically copying all of column G and column K, removing the duplicates, and pasting those unique values of column G on column Q and those unique values of column K on column Y. The purpose is to do a SumIf calclation that I have placed on the columns next to where the unique values would be found. Please help me if you can !!! Here is my code up to now:


Sub CopyUnique()

Dim LR As Long, i As Long, LR2 As Long, s As Long


Sheets("Verify Dispatch").Range("Q3:Q1000").ClearContents
Sheets("Verify Dispatch").Range("Y3:Y1000").ClearContents
Sheets("Verify Dispatch").Range("R4:X1000").ClearContents
Sheets("Verify Dispatch").Range("Z4:AF1000").ClearContents


With Sheets("Verify Dispatch")
LR = .Range("G" & Rows.Count).End(xlUp).Row
.Range("G3:G" & LR).Copy Destination:=Sheets("Verify Dispatch").Range("Q" & Rows.Count).End(xlUp).Offset(1)
LR2 = .Range("K" & Rows.Count).End(xlUp).Row
.Range("K3:K" & LR2).Copy Destination:=Sheets("Verify Dispatch").Range("Y" & Rows.Count).End(xlUp).Offset(1)

For i = LR To 2 Step -1

If WorksheetFunction.CountIf(.Columns("Q"), .Range("Q" & i).Value) > 1 Then .Rows(i).Delete
On Error Resume Next
.Columns("Q").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0

Next i

For s = LR2 To 2 Step -1

If WorksheetFunction.CountIf(.Columns("Y"), .Range("Y" & s).Value) > 1 Then .Rows(s).Delete
On Error Resume Next
.Columns("Y").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0

Next s




End With


End Sub



THANK YOU !!

 

[DanteAmor]

Try this

Sub CopyUnique()
    Dim sh As Worksheet
    Dim lr As Long, i As Long, lr2 As Long, s As Long
    
    Set sh = Sheets("Verify Dispatch")
    sh.Range("Q3:Q1000, Y3:Y1000, R4:X1000, Z4:AF1000").ClearContents
    
    lr = sh.Range("G" & Rows.Count).End(xlUp).Row
    sh.Range("G3:G" & lr).Copy Destination:=sh.Range("Q" & Rows.Count).End(xlUp).Offset(1)
    lr2 = sh.Range("K" & Rows.Count).End(xlUp).Row
    sh.Range("K3:K" & lr2).Copy Destination:=sh.Range("Y" & Rows.Count).End(xlUp).Offset(1)
    
    sh.Range("Q3:Q" & lr).RemoveDuplicates Columns:=1, Header:=xlNo
    sh.Range("Y3:Y" & lr).RemoveDuplicates Columns:=1, Header:=xlNo


End Sub

 

[aroig07]

Thank you so much for the quick response !! This worked so that the entire row would not be deleted, but it is now showing me duplicate values and not the unique. Just gives me like 6 values but are all the same.



Sub CopyUnique()

Dim sh As Worksheet
Dim LR As Long, i As Long, LR2 As Long, s As Long


Set sh = Sheets("Verify Dispatch")


sh.Range("Q3:Q1000").ClearContents
sh.Range("Y3:Y1000").ClearContents
sh.Range("R4:X1000").ClearContents
sh.Range("Z4:AF1000").ClearContents


LR = sh.Range("G" & Rows.Count).End(xlUp).Row
sh.Range("G3:G" & LR).Copy Destination:=sh.Range("Q" & Rows.Count).End(xlUp).Offset(1)
LR2 = sh.Range("K" & Rows.Count).End(xlUp).Row
sh.Range("K3:K" & LR2).Copy Destination:=sh.Range("Y" & Rows.Count).End(xlUp).Offset(1)

sh.Range("Q3:Q" & LR).RemoveDuplicates Columns:=1, Header:=xlNo
sh.Range("Y3:Y" & LR2).RemoveDuplicates Columns:=1, Header:=xlNo

End Sub

 

[DanteAmor]

Check that the data does not have spaces before or after, that makes them unique.

 

[aroig07]

There are some that have spaces in between them, is there a way to do it with spaces in between. This is something that will occur in the day to day... Thanks again !!!

 

[DanteAmor]

You must correct your data, if you have:

"Hello World"
"          Hello World            "
"Hello                    World"

They are 3 different registers. First fix your data and you will see that the macro works correctly.

 

[aroig07]

Oh ! Yeah, the data would not be on different spacing forms like you explained above. They are like this:

DR040

DR040
DT9033
RT7663

RT7663
DR040



but are showing me only:

DR040
DR040
DR040
DR040
DR040

 

[DanteAmor]

Do you have formulas?
Then paste only values

sh.Range("G3:G" & lr).Copy 
sh.Range("Q" & Rows.Count).End(xlUp).Offset(1).pastespecial paste:=xlPasteValues

 

[aroig07]

This worked perfectly !!! Thank you so much, it is now showing me the unique values. Is there a way I could make the macro ignore those formulas that come out blank ??? If not, this works out ok for me.

Thank you again !!!!

 

[DanteAmor]

Corrects the formula so that the result of the formula is a value or ""