Set Range object problem in occurrence count?

Below is the code to find unique names and the number of times each has occurred. The data is on one sheet the results on another.

The problem code is in the bottom half, count occurrences on Sheet2 & list count on Sheet1. (Parts are commented!) If any one has a solution, thank's.

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 rng 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")
'Code is fine down to here!

'Problem code!
Set tallyRange = Worksheets("Sheet2").Range(Range("I1"), Range("I1").End(xlDown)).Offset(0, 1)
Set fillRange = Worksheets("Sheet1").Range("J1")
With Worksheets("Sheet2").Range("J1")
'Count occurrences of names on Sheet2.
.Formula = "=CountIf(" & Intersect(Columns(8), ActiveSheet.UsedRange).Address & ",I1)"
.AutoFill Destination:=Range(fillRange.Address)
End With
With tallyRange
'List the number of times each unique name occurred on Sheet2, next to the list on sheet1.
.Copy Destination:=Range(fillRange.Address)
.PasteSpecial (xlValues)
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
Sheets("Sheet1").Select
Range("A1").Select
End Sub