You left out a lot of info. It appears you are trying to write a sub for each name
I don't have a CountIfs in my version, so this is not tested
Option Explicit
Option Base 1 'For easier Arrays
Enum ArrayIndices 'For clarity of code
Individ = 1
Yesses
Noes
Refusals
NAs
End Enum
Sub CountMTDs()
Const ReportSheet As String = "MTDsReport" 'Edit Name to suit
Dim Names As New Scripting.Dictionary
Dim Cel As Range
Dim Report, Headers
Dim i As Long
'Create Unique list of Individuals
With Sheets("Report_Resullts")
For Each Cel In .Intersect(.UsedRange, Range("B:B"))
On Error Resume Next
Names.Add Cel, "True"
Err = 0
Next Cel
End With
'Check Conditon of Reports sheet
SheetCondition ReportSheet 'See next Sub
'Set Headers
Headers = Array("Individual", "Yes", "No", "Refused", "Not Applicable")
With Sheets(ReportSheet).Cells(1).Resize(1, UBound(Headers))
.Value = Headers.Value
.Font.Bold = True
.Font.Size = StandardFont.Size + 2
.HorizontalAlignment = xlCenter
End With
'Create Report for each individual
'Application.ScreenUpdating = False 'Remove Comment mark from beginning this line after testing
With Sheets("Report_Resullts")
For i = 1 To Names.Count
ReDim Report(1 To UBound(Headers)) 'Reset and Clear array
Report(Individ) = Names(i)
Report(Yesses) = WorksheetFunction.CountIfs(.Range("B:B"), "=" & Names(i), .Range("L:L"), "=Yes")
Report(Noes) = WorksheetFunction.CountIfs(.Range("B:B"), "=" & Names(i), .Range("L:L"), "=No")
Report(Refusals) = WorksheetFunction.CountIfs(.Range("B:B"), "=" & Names(i), .Range("L:L"), "=Refused")
Report(NAs) = WorksheetFunction.CountIfs(.Range("B:B"), "=" & Names(i), .Range("L:L"), "=Not Applicable")
'Write the Report to the sheet
Sheets(ReportSheet).Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(1, UBound(Headers)) = Report.Value
Next
End With
'Resize the columns to fit
Sheets(ReportSheet).Cells(1).CurrentRegion.Columns.AutoFit
Application.ScreenUpdating = True
End Sub
Private Sub SheetCondition(SheetToCheck As String)
'True if False
On Error Resume Next
If Not Sheets(SheetToCheck).Name = SheetToCheck Then
Sheets.Add Name = SheetToCheck
Err = 0
End If
'If the sheet didn't exist, it does now
Sheets(SheetToCheck).ClearContents
'Display it
Sheets(SheetToCheck).Activate
End Sub