Try out this code. It should calculate all figures you need.
Before you run the code fill dates of first days of the month in row 6. G6 = 2016.08.01, H6 = 2016.09.01 and so on.
Sub Button1_Click()
Dim arr
Dim vArr(1)
Dim dict
Dim dict2
Dim LR As Long
Dim count As Long
Dim i, j As Long
Dim dDate As Date
Dim StartDate, EndDate As Date
LR = Sheets("Sheet1").Cells(Sheets("Sheet1").Rows.count, "A").End(xlUp).Row
arr = Sheets("Sheet1").Range("B2:D" & LR)
dDate = Range("G7").Value
count = 0
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(arr)
If arr(i, 3) = "dog" And arr(i, 1) < dDate Then
If dict.Exists(arr(i, 2)) Then
vArr(0) = dict.Item(arr(i, 2))
vArr(0) = vArr(0) + 1
dict.Item(arr(i, 2)) = vArr(0)
Else
dict.Add arr(i, 2), 1
End If
End If
Next
For Each strKey In dict.Keys()
If dict.Item(strKey) > 1 Then
count = count + 1
End If
Next
Range("G8").Value = count
For j = 1 To 5
StartDate = Cells(6, j + 6).Value
EndDate = Cells(7, j + 7).Value
Set dict2 = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(arr)
If dict.Exists(arr(i, 2)) And dict.Item(arr(i, 2)) > 1 And arr(i, 1) >= StartDate And arr(i, 1) <= EndDate Then
If dict2.Exists(arr(i, 2)) Then
Else
dict2.Add arr(i, 2), 1
End If
End If
Next i
Cells(8, j + 7) = dict2.count
Set dict2 = Nothing
Next j
Set dict = Nothing
End Sub
Bookmarks