# selecting duplicates using a macro to find them

#### mani_singh

##### Well-known Member
how can i select only duplicates using a macro?

i have a list in which i have a set of duplicate values i need to select only the duplicate ones using a macro to have them worked on

any ideas?

### Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.

#### Lewiy

##### Well-known Member
Try this macro with your list in column A. Duplicates will be highlighted in red.
Code:
``````Sub Duplicates()
Dim limit As Long
Dim c As Long
limit = Cells(Rows.Count, 1).End(xlUp).Row
For c = 1 To limit
If WorksheetFunction.CountIf(Range("A1:A" & c), Range("A" & c)) > 1 Then
Cells(c, 1).Interior.ColorIndex = 3
End If
Next c
End Sub``````

#### mani_singh

##### Well-known Member
thanks for that one. its helped but what i need to do is take this duplicate data and cross reference the values against it in a table

item -- person
K604 0
K604 1
K604 3
K604 1

needs to become -

item -- person - 0 - 1 - 2 - 3
K604 -- 1 - 2 - 0 - 1

#### Lewiy

##### Well-known Member
Perhaps like this then:
Code:
``````Sub SortMe()
Dim ColLimit As Long
Dim RowLimit As Long
Dim c As Long
Dim r As Long
RowLimit = Cells(Rows.Count, 1).End(xlUp).Row
For r = 2 To RowLimit
For c = 2 To RowLimit
If Cells(r, 1) = Cells(c, 1) And r <> c Then
ColLimit = Cells(r, Columns.Count).End(xlToLeft).Column
Cells(r, ColLimit + 1) = Cells(c, 2)
End If
Next c
Next r
For r = RowLimit To 1 Step -1
If WorksheetFunction.CountIf(Range("A1:A" & r), Range("A" & r)) > 1 Then
Rows(r).Delete shift:=xlUp
End If
Next r
End Sub``````

#### mani_singh

##### Well-known Member
thanks for the quick reply but i've set the macro up and nothing happens at all! i've put the data into a sheet with headings in col a and b set and run the macro no errors but no activity either!

any ideas what i'm doing wrong

thank you

#### Lewiy

##### Well-known Member
I start off with it looking like this:
Excel Workbook
AB
1ItemNumber
2Type395
3Type217
4Type353
5Type152
6Type117
7Type376
8Type383
9Type133
10Type256
11Type156
12Type398
13Type361
14Type288
15Type255
16Type122
17Type151
18Type218
19Type116
20Type175
Sheet2

And it ends up like this after running the macro:
Excel Workbook
C
7
Sheet1

#### Lewiy

##### Well-known Member
Sorry, second one looks like this:
Excel Workbook
ABCDEFGHI
1ItemNumber
2Type3955376839861
3Type21756885518
4Type15217335622511675
Sheet1

#### mani_singh

##### Well-known Member
Thanks for the quick reply - thats almost what im tryin to get done! nice one.

the format is correct but the data needs sorting - by this i mean in stead of just placing the numbers horizontaly against the item name (i think if i use cell values to explain it'll be clearer) ok:

columns:

a = item names
b = number - going ot be either 0,1,2 or 3 (can have multiple instances e.g. item 1 - 0, item 1 - 0, item 1 - 2 etc)

c = total number of 0 item numbers (added up in this column cell)
d = total number of 1's (same idea as above)
e = total number of 2's
f = total number ok 3's
g = total number all together

#### Lewiy

##### Well-known Member
Code:
``````Sub SortMe()
Dim ColLimit As Long
Dim RowLimit As Long
Dim c As Long
Dim r As Long
Dim PersonArray(3) As Long
RowLimit = Cells(Rows.Count, 1).End(xlUp).Row
For r = 2 To RowLimit
Cells(r, 3) = 0
Cells(r, 4) = 0
Cells(r, 5) = 0
Cells(r, 6) = 0
For c = 2 To RowLimit
If Cells(r, 1) = Cells(c, 1) Then
Select Case Cells(c, 2)
Case 0
Cells(r, 3) = Cells(r, 3) + 1
Case 1
Cells(r, 4) = Cells(r, 4) + 1
Case 2
Cells(r, 5) = Cells(r, 5) + 1
Case 3
Cells(r, 6) = Cells(r, 6) + 1
End Select
End If
Next c
Next r
For r = RowLimit To 1 Step -1
If WorksheetFunction.CountIf(Range("A1:A" & r), Range("A" & r)) > 1 Then
Rows(r).Delete shift:=xlUp
End If
Next r
End Sub``````

#### mani_singh

##### Well-known Member
Lewiy - thank you so much thats exactly what i needed to have done! - i owe you a drink!

ALL THE BEST !

MANI

Replies
0
Views
749
Replies
1
Views
168
Replies
2
Views
490
Replies
5
Views
334
Replies
6
Views
744

1,181,367
Messages
5,929,552
Members
436,677
Latest member
CathalP1992

### 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.

### Which adblocker are you using?

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

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