Only counts first two items?

This code looks at a list of names on sheet2. Then prints a list of unique names on sheet1. Counts the number of times each name is on sheet2. Then lists the number of times each name occurs on on sheet2 next to the sorted list of names on sheet1.

The problem is only the first two names on the list, on sheet1 have the counts displayed?
The other names on the sorted list on sheet1 are blank where the number of occurrences should be displayed?

Any help! Thanks, JSW

Sub Find_Names()
'Finds all the unique names and count the number of times they are listed.
'Data is on Sheet2, Results are listed on Sheet1.
Dim tallyRange As Range
Dim fillRange As Range
'Find unique names on Sheet2 & list on Sheet1.

Application.ScreenUpdating = False
With Intersect(Columns(8), ActiveSheet.UsedRange)
.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
.SpecialCells(xlCellTypeVisible).Copy Destination:=Worksheets("Sheet1").Range("I1")
ActiveSheet.ShowAllData
End With
'Sort unique names on sheet1.

Sheets("Sheet1").Select
Columns(9).Sort Key1:=Range("I1")

Set tallyRange = Range(Range("I1"), Range("I1").End(xlDown)).Offset(0, 1)
Set fillRange = Worksheets("Sheet1").Range("J1")
With Worksheets("Sheet1")
'Count occurrences of names on Sheet2.

.Range("J1").Formula = "=CountIf(Sheet2!" & Intersect(Sheet2.Columns(8), Sheet2.UsedRange).Address & ",I1)"
.Range("J1:J" & .Range("h1").End(xlDown).Row).FillDown
End With
With Range(Range("I1"), Range("I1").End(xlDown)).Offset(0, 1)
'List the number of times each unique name occurred on Sheet2, next to the list on sheet1.

.Copy Destination:=Range(Worksheets("Sheet1").Range("J1").Address)
'.PasteSpecial (xlValues)
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
Sheets("Sheet1").Select
Range("A1").Select
End Sub