Sub Summarize()
Application.ScreenUpdating = False
Dim i As Long, j As Long, k As Long
Dim StrName As String, iTally As Long
With ThisWorkbook.Sheets("Sheet2")
  For i = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
    StrName = .Range("A" & i).Value
    iTally = 0
    With ThisWorkbook.Sheets("Sheet1")
      For j = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
        For k = 2 To .Cells.SpecialCells(xlCellTypeLastCell).Column
          If .Cells(j, k).Value = StrName Then
            iTally = iTally + 1
            Exit For
          End If
        Next
      Next
    End With
    .Range("B" & i).Value = iTally
  Next
End With
Application.ScreenUpdating = True
End Sub