Count number of items by month/year using CreateObject

[Besacly]

Sheet1 "Source", I have Items column B and Date column C.

Sheet2 "Result", I get the name of the Items column C and the related number of Items column D with the code below.

The code runs very well. However, how should I modify it to get the number of Items by month/year ?
I could e.g. enter the requested month/year in B1-B2 in Sheet2.

Thanks for your help !

Sub TestCount()
    
Dim rng As Range
Dim Data As Variant
Dim Key As Variant
Dim i As Long

    Set rng = ThisWorkbook.Worksheets("Sheet1").Range("B2:B500000")
        Data = rng.Value
            With CreateObject("Scripting.Dictionary")
                For i = 1 To UBound(Data, 1)
                    Key = Data(i, 1)
                        If Not IsError(Key) And Not IsEmpty(Key) Then
                            .Item(Key) = .Item(Key) + 1
                        End If
                Next i
                        If .Count = 0 Then
                            Exit Sub
                        End If
                            ReDim Data(1 To .Count, 1 To 2)
                                i = 0
                For Each Key In .keys
                    i = i + 1
                        Data(i, 1) = Key
                            Data(i, 2) = .Item(Key)
                Next Key
            End With
            
            With ThisWorkbook.Worksheets("Sheet2").Range("C2")
                Set rng = .Resize(UBound(Data, 1), 2)
            End With
        rng.Value = Data
    
End Sub

 

[pbornemeier]

This does what you asked for. Put the Month and Year in as full dates.

Option Explicit

Sub TestCount()
    
    Dim rng As Range
    Dim Data As Variant
    Dim dteData As Variant
    Dim Key As Variant
    Dim i As Long
    Dim lMonth As Long
    Dim lYear As Long

    lMonth = Month(Worksheets("Sheet2").Range("B1"))
    lYear = Year(Worksheets("Sheet2").Range("B2"))

    Set rng = ThisWorkbook.Worksheets("Sheet1").Range("B2:B500000")
        Data = rng.Value
        dteData = rng.Offset(0, 1).Value
            With CreateObject("Scripting.Dictionary")
                For i = 1 To UBound(Data)
                    If Month(dteData(i, 1)) = lMonth And Year(dteData(i, 1)) = lYear Then
                        Key = Data(i, 1)
                        If Not IsError(Key) And Not IsEmpty(Key) Then
                            .Item(Key) = .Item(Key) + 1
                        End If
                    
                    End If
                Next i
                        If .Count = 0 Then
                            Exit Sub
                        End If
                            ReDim Data(1 To .Count, 1 To 2)
                                i = 0
                For Each Key In .keys
                    i = i + 1
                        Data(i, 1) = Key
                            Data(i, 2) = .Item(Key)
                Next Key
            End With
            
            With ThisWorkbook.Worksheets("Sheet2").Range("C2")
                Set rng = .Resize(UBound(Data, 1), 2)
            End With
        rng.Value = Data
    
End Sub