Find matching values in one column

[ipbr21054]

I’m looking to find matching values “customers names” in one column.
This column being column A

I can’t use a code where the user would manually enter a customers name as that would take far to long.

The code needs to decipher the names in column A itself.
The code would only need to be interested in customers names that match & have appeared more than once.

The names are saved like so.
TOM JONES 001
BOB SMITH 003

The code would need to ignore the 001 002 003 etc etc part & concentrate on the name.

Maybe best to put these names in a listbox along with its row number ??

What do you think, any advice welcome please.
Thanks.

 

[alansidman]

1. Are you still using Xl2007. If not, please update to your current version
2. Please supply 8-10 records of data, using XL2BB and then mock up your expected results. This will expedite a solution.

 

[ipbr21054]

Morning,
I hope this is ok for you.

The code should look in column A for any customers name that appear more than once & populate a listbox to show the user the customers in question.

In this example the code should find the following & populate a listbox

TOM JONES 001 Row 10
TOM JONES 002 Row 18

MEL SMITH 001 Row 14
MEL SMITH 002 Row 19
MEL SMITH 003 Row 29

PAUL MEA 001 Row 12
PAUL MEA 002 Row 23

My complete list at present has say 2450 rows.
Once this has been complete i can the put something in place so i dont have to use this agin.

Many Thanks
Windows 7 Professional
Office 2007 is being used.

TEST.xlsm
	A	B	C	D	E	F	G	H	I	J
8	02/01/2017	DAVID WINTON 001	JAGUAR SMART KEY		KX469585427GB	EBAY	04/01/2017			ROYAL MAIL
9	02/01/2017	KELVIN GOH 001	ORDER		RS039542413GB	WEB SITE	11/01/2017			ROYAL MAIL
10	02/01/2017	TOM JONES 001	SUZUKI SMART REMOTE		KX469585435GB	EBAY	04/01/2017			ROYAL MAIL
11	02/01/2017	JAMES GOLBY 001	TOUAREG KEY BLADE	X 2	KX469585413GB	EBAY	04/01/2017			ROYAL MAIL
12	03/01/2017	PAUL MEA 001	FORD KEY	143434	RS039542427GB	EBAY	11/01/2017			ROYAL MAIL
13	03/01/2017	JAMES WRATTEN 001	SMART CAR KEY		KX469585444GB	EBAY	N/A			ROYAL MAIL
14	03/01/2017	MEL SMITH 001	STEERING LOCK		P9524468	EBAY	05/01/2017			ROYAL MAIL
15	04/01/2017	BLAKE BURCHILL 001	FORD KEY	80 BIT	KX469585475GB	EBAY	06/01/2017			ROYAL MAIL
16	04/01/2017	MAURICE CARUANA 001	HONDA S2000 FOB	348	RS039542435GB	EBAY	11/01/2017			ROYAL MAIL
17	04/01/2017	NICOLAE COSTACHESCU 001	HONDA S2000 FOB	453	KX469585458GB	EBAY	05/01/2017			ROYAL MAIL
18	05/01/2017	TOM JONES 002	HONDA S2000 FOB	348	KX469585489GB	EBAY	06/01/2017			ROYAL MAIL
19	05/01/2017	MEL SMITH 002	ORDER		AF567319466GB	WEB SITE	06/01/2017			ROYAL MAIL
20	06/01/2017	JONAS MALMBERG 001	FORD GALAXY KEY	ID42	RS039542696GB	EBAY	12/04/2017			MY HERMES
21	06/01/2017	JOHN WILLIAMS 003	TRANSIT BLUE HORSE SHOE		KX469585492GB	EBAY	N/A			MY HERMES
22	09/01/2017	ALEX CHEERS 001	HONDA LOGO	RED	STAMP	EBAY	16/01/2017			ROYAL MAIL
23	09/01/2017	PAUL MEA 002	HONDA S2000 FOB	350	KX469585515GB	WEB SITE	11/01/2017			ROYAL MAIL
24	09/01/2017	DAVID MCGRATH 001	VW LUPO KEY	ID 44	KX469585501GB	EBAY	10/01/2017			ROYAL MAIL
25	10/01/2017	ROGER MATHEWS 001	MAZDA FLIP REMOTE		KX469585529GB	EBAY	11/01/2017			ROYAL MAIL
26	10/01/2017	GRAHAM DANIELS 001	SMART CAR REMOTE	1B	RS039542444GB	EBAY	16/01/2017			ROYAL MAIL
27	11/01/2017	AUTO CARE SALES 001	SUZUKI KEY	4C	KX469585532GB	EBAY	12/01/2017			ROYAL MAIL
28	16/01/2017	MARK WALKER 001	SPARKRITE FOB		KX469585577GB	EBAY	21/01/2017			ROYAL MAIL
29	16/01/2017	MEL SMITH 003	SUZUKI KEY	4D65	KX469585563GB	WEB SITE	19/01/2017			ROYAL MAIL
POSTAGE

 

[RobP]

Hi, so I took a stab and made some progress for you possibly:

The code will put the duplicate names and row number into a 2D array "Dup_names()" - which you can use to do anything else with if you like.
My last routine just accesses each item in that array, and puts the list in columns H (name) and I (row number of interest).

Hope it helps you in your quest.

Rob

Sub duplicates()

Dim x, count, lastrow As Long
Dim arr_names(), dup_names() As String

lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
ReDim arr_names(1 To lastrow)
ReDim dup_names(1 To 2, 1 To lastrow)

arr_names = Range("B1:B" & lastrow)

For Rnum = 1 To lastrow
    arr_names(Rnum, 1) = Left(arr_names(Rnum, 1), Len(arr_names(Rnum, 1)) - 4)
Next Rnum

x = 1  'set row number start for duplicates array
For Rnum = 1 To lastrow
    check_name = arr_names(Rnum, 1)
    For Lnum = Rnum + 1 To lastrow
        If check_name = arr_names(Lnum, 1) Then
            dup_names(1, x) = check_name
            dup_names(2, x) = Rnum
            x = x + 1
        End If
    Next Lnum
Next Rnum

ReDim Preserve dup_names(1 To 2, 1 To x - 1)

'display duplicates in Col H & I
For Count = 1 To x - 1
    Range("H" & Count) = dup_names(1, Count)
    Range("I" & Count) = dup_names(2, Count)
Next Count

End Sub

 

[ipbr21054]

Hi,
When i run the code i see variable not defind.
This is shown in yellow

For Rnum = 1 To lastrow

 

[RobP]

you can add it to the Dim line for Long at the too of the routine ?
its a long integer.

cheers
Rob

 

[ipbr21054]

Ok so I added Dim Rnum As Integer but the code then fails a few lines down.

Then we have a power cut so typing from phone.

 

[ipbr21054]

So power on & as mentioned above i have added
Dim Rnum As Interger
But now it shows Variable not defined for this line check_name = arr_names(Rnum, 1)

 

[NoSparks]

Book1
	A	B	C	D
1		CUSTOMER	IS ON ROW(S)
2		DAVID WINTON	8
3		KELVIN GOH	9
4		TOM JONES	10, 18
5		JAMES GOLBY	11
6		PAUL MEA	12, 23
7		JAMES WRATTEN	13
8		MEL SMITH	14, 19, 29
9		BLAKE BURCHILL	15
10		MAURICE CARUANA	16
11		NICOLAE COSTACHESCU	17
12		JONAS MALMBERG	20
13		JOHN WILLIAMS	21
14		ALEX CHEERS	22
15		DAVID MCGRATH	24
16		ROGER MATHEWS	25
17		GRAHAM DANIELS	26
18		AUTO CARE SALES	27
19		MARK WALKER	28
20
21
Sheet2

Based on the sheet you've provided, that is what I come up with using this code

Sub NamesOnRows()
    Dim lr As Long
    Dim rng As Range, cel As Range
    Dim dic As Object
    Dim cust As String

With Sheets("POSTAGE")
    lr = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    Set rng = .Range("B8:B" & lr)
End With

Set dic = CreateObject("Scripting.Dictionary")

For Each cel In rng
    'just the name
    cust = Trim(Left(cel.Value, Len(cel.Value) - 3))
    'check if name exists in dictionary
    If Not dic.exists(cust) Then
        'if not add it with it's row number
        dic(cust) = cel.Row
    Else
        'if exists, add this row number also
        dic(cust) = dic(cust) & ", " & cel.Row
    End If
Next cel

' Write the customer names and row numbers to another sheet
With Sheets("Sheet2")   ' change to suit
    .Range("B2").Resize(dic.count) = Application.Transpose(dic.keys)  ' the customer names
    .Range("C2").Resize(dic.count) = Application.Transpose(dic.items) ' the rows they're on
End With

End Sub

 

[ipbr21054]

Hi,

With the code above i have now installed.
The sheet in which the values are stored is Sheet4 & columns are reference is B2 C2

I run the code & it populates the column B with customers name BUT not the rows that they are in.

I then tried it on the file that was supplied in the group doing the same thing & all works fine.
Strange as the file i supplied was from the sheet im trying to use it on

Take a look at the screenshot please

Code in use

Private Sub MoreThanOne_Click()
    Dim lr As Long
    Dim rng As Range, cel As Range
    Dim dic As Object
    Dim cust As String

With Sheets("POSTAGE")
    lr = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    Set rng = .Range("B8:B" & lr)
End With

Set dic = CreateObject("Scripting.Dictionary")

For Each cel In rng
    'just the name
    cust = Trim(Left(cel.Value, Len(cel.Value) - 3))
    'check if name exists in dictionary
    If Not dic.Exists(cust) Then
        'if not add it with it's row number
        dic(cust) = cel.Row
    Else
        'if exists, add this row number also
        dic(cust) = dic(cust) & ", " & cel.Row
    End If
Next cel

' Write the customer names and row numbers to another sheet
With Sheets("Sheet4")   ' change to suit
    .Range("B2").Resize(dic.count) = Application.Transpose(dic.Keys)  ' the customer names
    .Range("C2").Resize(dic.count) = Application.Transpose(dic.Items) ' the rows they're on
End With
End Sub