need help getting names to match

[kevin lazell]

hi guys i have failed miserably to get this to work i have attatched a snap shot of my worksheet with intended result being the 3rd box
what i need code to do is lookup first name in cell a2 and check to see if it is in b2 if it is then check if interior color in c2 matches c1 it does not
so then checks d2 and d1 now this matches so j2=j2+1 now we go back and check if a2 is in b3 then a2 is in b4 etc then the code will start all over again
now checking 2nd name in cell a3 with cell b2 and b3 and b4 and so on
i think the main problem is in checking the name when using key f8 to step through the code and hover over fnd it displays the four names

Dim Fnd As Range
Dim a, x, name As Variant
a = 2: name = 2: x = 0
again:
x = x + 1

Set Fnd = Range("b:b").Find(Range("a" & name).Value, , , xlPart, , , False, , False)

If Fnd Is Nothing Then a = a + 1: GoTo again:






If Range("c" & a).Interior.ColorIndex = Range("c1").Interior.ColorIndex Then Range("i" & a) = Range("i" & a) + 1
If Range("d" & a).Interior.ColorIndex = Range("d1").Interior.ColorIndex Then Range("j" & a) = Range("j" & a) + 1
If Range("e" & a).Interior.ColorIndex = Range("e1").Interior.ColorIndex Then Range("k" & a) = Range("k" & a) + 1
If Range("f" & a).Interior.ColorIndex = Range("f1").Interior.ColorIndex Then Range("l" & a) = Range("l" & a) + 1
If Range("g" & a).Interior.ColorIndex = Range("g1").Interior.ColorIndex Then Range("m" & a) = Range("m" & a) + 1


a = a + 1
If x = 60 Then Exit Sub
If a = 12 Then a = 2: name = name + 1
GoTo again:
this is as far as i have got with the code a bit messy i know but just toying with it at the moment
any help will be greatly appreciated tia

 

[Snakehips]

@kevin lazell Assuming I have understood correctly, perhaps give this a try and see if it assists you.
NB I have not used your same variables so just test it stand alone.

Sub crewtest()

LastRow = Range("A" & Rows.Count).End(xlUp).Row

For r = 2 To LastRow
Name = Cells(r, 1)
Done = 0
    For i = 2 To LastRow
        If Cells(i, 2) Like "*" & Name & "*" Then
            For c = 3 To 7
             If Cells(i, c).Interior.ColorIndex = Cells(1, c).Interior.ColorIndex Then
                Cells(i, c + 6) = Cells(i, c + 6) + 1
                Done = 1
                Exit For
             End If
            Next c
        End If
        If Done = 1 Then Exit For
    Next i

Next r

End Sub

Hope that helps.

 

[kevin lazell]

hi snakehips
thank you for this lovely piece of code but the result was not right in my snapshot the 3rd box is the result i need
with your code it only put out 4 results in ( j2 it gave 4 should be 2 ) ( i3 it gave 3 should be1 ) ( j4 it gave 2 should be 0 ) and ( l5 it gave 1 should be 2 )
any ideas what is wrong cheers

 

[Snakehips]

Kevin. I'm sorry but I cannot yet understand what logic to apply in order to generate your result in columns O:S
Please treat me as an idiot and endeavour to explain clearly. Do you require the I:M result?

 

[kevin lazell]

good morning snakehips
i am having a look at it now one problem i discovered is that when the code starts to run it is looking for kevin lazell
it finds it in b2 then checks the color of cell c2 to see if it matches c1 in this case it does not match the programme
then runs again looking for kevin lazell it finds it in b2 then does the color check d2 and d1 this is a match it then
lets d2=d2+1 prog goes back to the begining and selects the next name in the list where as it should continue to the bottom
as kevin lazell appears four times in the b column if you could amend your code to do that i will run it again and see what happens
i hope this is clear enough for you tia m8

 

[Snakehips]

I think you will find this is ok?
Took me ages as when i had modified the code I still could not get your desired result.
But i got it in the end. Remembered I had entered my data to match yours, which has two name typos in row 5 and row 6 column B that were screwing things up!!!

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M
1	Name	Crews	ph1	ph2	ph3	ph4	ph5	Name	ph1	ph2	ph3	ph4	ph5
2	kevin lazell	paul day,fred smith,andrew dobs,kevin lazell						kevin lazell		2	1		1
3	john smith	les redford,joe marsh,peter clue, paul day						john smith	1		1	1	1
4	peter clue	karen lazell,kevin lazell,harry mills, fred smith						peter clue	1		1		2
5	les redford	joe marsh,harry mills,john smith,les redford						les redford	1		1	2
6	harry mills	john smith,peter clue,fred smith,joe marsh						harry mills		1	1	2
7	karen lazell	andrew dobs,karen lazell,john smith, peter clue						karen lazell	1	1	1		1
8	joe marsh	harry mills,paul day,kevin lazell,les redford						joe marsh	1			2	1
9	paul day	paul day,karen lazell,john smith,andrew dobs						paul day	2	1	1
10	fred smith	harry mills,andrew dobs,joe marsh,les redford						fred smith		2			2
11	andrew dobs	kevin lazell,karen lazell,peter clue,fred smith						andrew dobs	1	1	1	1
andrew dobs

Revised code

Sub crewtest2()
LastRow = Range("A" & Rows.Count).End(xlUp).Row

For r = 2 To LastRow
Name = Cells(r, 1)

    For i = 2 To LastRow
        If Cells(i, 2) Like "*" & Name & "*" Then
            For c = 3 To 7
             If Cells(i, c).Interior.ColorIndex = Cells(1, c).Interior.ColorIndex Then
                Cells(r, c + 6) = Cells(r, c + 6) + 1
                Done = 1
                Exit For
             End If
            Next c
        End If
      
    Next i

Next r

End Sub

In future if you can use XL2BB to post your dat it will make it so much easier for folk to replicate and help.

 

[kevin lazell]

snakehips that is brilliant !!!!!!! it works a treat
bless you
thank you and have a good day m8

 

[Snakehips]

Great! You are welcome.

 

[kevin lazell]

good morning snakehips
i have another problem if you would be so kind to help please
i amended your code thus
Sub Button4_Click()

LastRow = Range("A" & Rows.Count).End(xlUp).Row

For r = 2 To LastRow
name = Cells(r, 1)
LastRow2 = Range("b" & Rows.Count).End(xlUp).Row

For i = 2 To LastRow2
If Cells(i, 2) Like "*" & name & "*" Then
For c = 3 To 7
If Cells(i, c).Interior.ColorIndex = Cells(1, c).Interior.ColorIndex Then

Sheets("sheet2").Cells(r, c) = Cells(r, c) + 1

Done = 1

Exit For
End If
Next c
End If

Next i

Next r


End Sub
the first change i made is with lastrow2 as column b is far longer than the screenshot shows (188 rows)
done a test run and it worked fine
the second change was to send the result to sheet 2 but i am only getting a 1 in each cell
see screenshot range o2:s11 all the right cells are populating but not getting the 2's
i cant see why it should of changed
tia m8

 

[Snakehips]

Kevin,
You have not referenced Sheet 2 cell for both elements of the line that updates Cells(r,c) !!
So it will always be setting to the Active sheet cell + 1 which will always be 1 if active sheet cells are empty!!!
Edit as per below.

Sheets("sheet2").Cells(r, c) = Sheets("sheet2").(r, c) + 1

Also, Done = 1 <<<<<<< line is redundant and I forgot to delete it so, you can.