PDA

View Full Version : Best Match



lienlee
08-30-2010, 12:38 PM
Im trying to match a persons hobby's with other people's hobbies and find the best match for that person.

For example
Person A's hobbies
is compared to

Person B
Person C
Person D

and based on the hobbies of B,C,D compared to A whichever matches the most would be person A's best match
if tie list both or more.

I attached a sample document
with fake data..
Note a person can have many hobbies. so i need to compare up to the next persons name. which you will see in the sample document

mohanvijay
09-01-2010, 05:28 AM
Hai use this code

i attached solved one




Dim hold() As Variant
Dim name_(1 To 3000), n_row(1 To 3000) As Variant
Dim name_ct, in_hobby As Integer
Dim b1, b2, b3 As Boolean
b1 = False
b2 = False
b3 = False



name_ct = 0
in_hobby = 1


name_row = Cells(Rows.Count, 1).End(xlUp).Row
hobby_row = Cells(Rows.Count, 2).End(xlUp).Row

For name_count = 2 To name_row
chk_val = Cells(name_count, 1).Value
If chk_val <> "" Then
name_(name_ct + 1) = chk_val
n_row(name_ct + 1) = Cells(name_count, 1).Row
name_ct = name_ct + 1
End If
Next name_count

ReDim hold(1 To hobby_row - 1) As Variant

For take = 2 To hobby_row
hold(in_hobby) = Cells(take, 2).Value
in_hobby = in_hobby + 1
Next take

For i = 1 To hobby_row - 1
chk_this = hold(i)
fin_row = Cells(i + 1, 1).Row

For fcn = 1 To name_ct
If fin_row >= n_row(name_ct) Then
cur_nam = name_(name_ct)
cur_row = n_row(name_ct)
Exit For
ElseIf fin_row = n_row(fcn) Then
cur_nam = name_(fcn)
cur_row = n_row(fcn)
Exit For
Else
For ia = 1 To name_ct
epp_row = fin_row - n_row(ia)
If epp_row < 0 Then
cur_nam = name_(ia - 1)
cur_row = n_row(ia - 1)
b1 = True
Exit For
End If
Next ia
End If
If b1 = True Then Exit For
Next fcn


For ii = 1 To hobby_row - 1
mat_this = hold(ii)
fin_row1 = Cells(ii + 1, 1).Row

For fcn1 = 1 To name_ct
If fin_row1 >= n_row(name_ct) Then
run_nam = name_(name_ct)
run_row = n_row(name_ct)
Exit For
ElseIf fin_row1 = n_row(fcn1) Then
run_nam = name_(fcn1)
run_row = n_row(fcn1)
Exit For
Else
For ib = 1 To name_ct
epp_row1 = fin_row1 - n_row(ib)
If epp_row1 < 0 Then
run_nam = name_(ib - 1)
run_row = n_row(ib - 1)
b2 = True
Exit For
End If
Next ib
End If
If b2 = True Then Exit For
Next fcn1

If i <> ii And chk_this = mat_this And cur_row <> run_row Then
If Cells(cur_row, 3).Value = "" Then
Cells(cur_row, 3).Value = run_nam
Else
Cells(cur_row, 3).Value = Cells(cur_row, 3).Value & " ," & run_nam
End If
End If

Next ii

b1 = False
b2 = False

Next i

lienlee
09-01-2010, 08:36 AM
Hi mohanvijay,
It works perfectly, but it prints the name x amount of times depending how many hobbies match

for example if 2 hobbies match between a person it shows the name twice
Or if anything. in another column count how many times that person names showed up so for example in another column

5- Persons name, 3- Persons name, but preferable I need it to show 1 name if that have the most hobbies matching with another person

i attached the copy with new data.

Thanks for getting back to me!

mohanvijay
09-02-2010, 03:00 AM
use this code

check it out in all the ways




Dim hold() As Variant
Dim name_(1 To 3000), n_row(1 To 3000) As Variant
Dim name_ct, in_hobby As Integer
Dim b1, b2, b3 As Boolean
b1 = False
b2 = False
b3 = False



name_ct = 0
in_hobby = 1


name_row = Cells(Rows.Count, 1).End(xlUp).Row
hobby_row = Cells(Rows.Count, 2).End(xlUp).Row

For name_count = 2 To name_row
chk_val = Cells(name_count, 1).Value
If chk_val <> "" Then
name_(name_ct + 1) = chk_val
n_row(name_ct + 1) = Cells(name_count, 1).Row
name_ct = name_ct + 1
End If
Next name_count

ReDim hold(1 To hobby_row - 1) As Variant

For take = 2 To hobby_row
hold(in_hobby) = Cells(take, 2).Value
in_hobby = in_hobby + 1
Next take

For i = 1 To hobby_row - 1
chk_this = hold(i)
fin_row = Cells(i + 1, 1).Row

For fcn = 1 To name_ct
If fin_row >= n_row(name_ct) Then
cur_nam = name_(name_ct)
cur_row = n_row(name_ct)
Exit For
ElseIf fin_row = n_row(fcn) Then
cur_nam = name_(fcn)
cur_row = n_row(fcn)
Exit For
Else
For ia = 1 To name_ct
epp_row = fin_row - n_row(ia)
If epp_row < 0 Then
cur_nam = name_(ia - 1)
cur_row = n_row(ia - 1)
b1 = True
Exit For
End If
Next ia
End If
If b1 = True Then Exit For
Next fcn


For ii = 1 To hobby_row - 1
mat_this = hold(ii)
fin_row1 = Cells(ii + 1, 1).Row

For fcn1 = 1 To name_ct
If fin_row1 >= n_row(name_ct) Then
run_nam = name_(name_ct)
run_row = n_row(name_ct)
Exit For
ElseIf fin_row1 = n_row(fcn1) Then
run_nam = name_(fcn1)
run_row = n_row(fcn1)
Exit For
Else
For ib = 1 To name_ct
epp_row1 = fin_row1 - n_row(ib)
If epp_row1 < 0 Then
run_nam = name_(ib - 1)
run_row = n_row(ib - 1)
b2 = True
Exit For
End If
Next ib
End If
If b2 = True Then Exit For
Next fcn1

If i <> ii And UCase(chk_this) = UCase(mat_this) And cur_row <> run_row Then
If Cells(cur_row, 3).Value = "" Then
Cells(cur_row, 3).Value = run_nam
Else
Cells(cur_row, 3).Value = Cells(cur_row, 3).Value & "," & run_nam
End If
End If

Next ii

b1 = False
b2 = False

Next i

Dim t_tol(1 To 3000), t_con(1 To 3000), pr_co(1 To 3000), pr_cos(1 To 3000) As Variant
Dim c_con, same_yes As Integer
Dim yes As Boolean

c_con = 1
yes = False
same_yes = 0

For final = 1 To name_ct
sor = Cells(n_row(final), 3).Value
If sor <> "" Then
piri = Split(sor, ",")
c_piri = WorksheetFunction.CountA(piri)
For con_ = 0 To c_piri - 1
un_con = piri(con_)
For con_1 = 1 To c_con
If t_con(con_1) = un_con Then yes = True
Next con_1
If yes = False Then
t_con(c_con) = un_con
c_con = c_con + 1
End If
yes = False
Next con_
End If

For xx = 1 To c_con - 1
pr_co(xx) = WorksheetFunction.CountA(Filter(piri, t_con(xx)))
Next xx


For same = 1 To c_con - 1
ch_pr = pr_co(same)
For same_1 = 1 To c_con - 1
ch_pr1 = pr_co(same_1)
same_x = ch_pr - ch_pr1
If same_x <> 0 Then same_yes = same_yes + 1
Next same_1
Next same

If same_yes = 0 Then
Cells(n_row(final), 3).Value = ""
For pri_sa = 1 To c_con - 1
If Cells(n_row(final), 3).Value = "" Then
Cells(n_row(final), 3).Value = t_con(pri_sa) & " - " & pr_co(pri_sa)
Else
Cells(n_row(final), 3).Value = Cells(n_row(final), 3).Value & " , " & t_con(pri_sa) & " - " & pr_co(pri_sa)
End If
Next pri_sa
Else
Cells(n_row(final), 3).Value = ""
mm = WorksheetFunction.Max(pr_co)
For eppudi = 1 To c_con - 1
xm = pr_co(eppudi)
If xm = mm Then
If Cells(n_row(final), 3).Value = "" Then
Cells(n_row(final), 3).Value = t_con(eppudi) & " - " & xm
Else
Cells(n_row(final), 3).Value = Cells(n_row(final), 3).Value & " , " & t_con(eppudi) & " - " & xm
End If
Else
If Cells(n_row(final), 4).Value = "" Then
Cells(n_row(final), 4).Value = t_con(eppudi) & " - " & xm
Else
Cells(n_row(final), 4).Value = Cells(n_row(final), 4).Value & " , " & t_con(eppudi) & " - " & xm
End If
End If
Next eppudi
End If

For xzx = 1 To c_con - 1
t_con(xzx) = ""
Next xzx

c_con = 1
mm = 0
xm = 0
same_yes = 0

Next final