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

Thread: Best Match

Thread Tools

Display

Best Match

Posting Permissions