counting items in list based on criteria

[rjwebgraphix]

I've done the following code and it works, but it's kind of slow. Does anyone have a better/faster way to count items in a list based on criteria?

The function that counts:

Function partcount(Strm As String, partnum As String)
Dim row As Long
Dim itemcnt As Long
row = 2
itemcnt = 0
Do While Sheets("Datasheet").Cells(row, "A") <> ""
    If Sheets("Datasheet").Cells(row, "C") = Strm And Sheets("Datasheet").Cells(row, "D") = partnum Then
        itemcnt = itemcnt + 1
    End If
row = row + 1
Loop
partcount = itemcnt
End Function

The code where the function is used:

Sub newusages()
Dim TotalPartCount As Long
Dim row As Long
 
Sheets("Usage").Activate
 
Rows("1:65000").Select
Selection.Delete Shift:=xlUp
 
Sheets("Datasheet").Cells(1, "U") = Sheets("Datasheet").Cells(1, "G")
Sheets("Datasheet").Cells(2, "U") = "USED"
Sheets("Datasheet").Cells(1, "V") = Sheets("Datasheet").Cells(1, "H")
Sheets("Datasheet").Cells(2, "V") = "ERSA"
 
Sheets("Datasheet").Range("C1:I65000").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Datasheet").Range("U1:V2"), _
CopyToRange:=Sheets("Usage").Range("A1:G1"), Unique:=True
 
Sheets("Datasheet").Cells(1, "U").ClearContents
Sheets("Datasheet").Cells(2, "U").ClearContents
Sheets("Datasheet").Cells(1, "V").ClearContents
Sheets("Datasheet").Cells(2, "V").ClearContents
'** Recorded move fields
    Columns("C:C").Select
    Selection.Cut
    Columns("H:H").Select
    Selection.Insert Shift:=xlToRight
    Columns("C:C").Select
    Selection.Cut
    Columns("G:G").Select
    Selection.Insert Shift:=xlToRight
    Range("F12").Select
'** end recording
 
Sheets("Usage").Cells(1, "H") = "Total"

row = 2
Do While Sheets("Usage").Cells(row, "A") <> ""
    
    TotalPartCount = partcount(Sheets("Usage").Cells(row, "A"), Sheets("Usage").Cells(row, "B"))
    Cells(row, "G") = TotalPartCount
    Cells(row, "H") = "=F" & row & "*G" & row
row = row + 1
Loop
End Sub