Count number of items by month/year using CreateObject

Besacly

New Member
Joined
Nov 23, 2020
Messages
1
Office Version
  1. 2016
Platform
  1. Windows
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 !

VBA Code:
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
 

Some videos you may like

Excel Facts

Return population for a City
If you have a list of cities in A2:A100, use Data, Geography. Then =A2.Population and copy down.

pbornemeier

Well-known Member
Joined
May 24, 2005
Messages
3,875
This does what you asked for. Put the Month and Year in as full dates.

VBA Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,118,413
Messages
5,571,964
Members
412,429
Latest member
brahmaiah
Top