【VBA】項目ごとのカウントを行う

 1Option Explicit
 2
 3Public Sub CountItem(sht As Worksheet, col As Long)
 4'###################################################################################
 5'シート上の項目のカウントを行い、メッセージボックスに表示する
 6'Dictionaryを使用するので、Microsoft Scripting Runtimeの参照設定が必要
 7'-----------------------------------------------------------------------------------
 8'引数  :sht 項目のカウントを行いたいシート
 9'      :col 項目のカウントを行いたい列番号
10'###################################################################################
11  
12  Dim lastRow As Long
13  lastRow = GetMaxRow(sht, col)
14  
15  Dim dic As Dictionary
16  Set dic = New Dictionary
17  Dim i As Long
18  Dim v As String
19  For i = 1 To lastRow
20    v = sht.Cells(i, 1)
21    If dic.Exists(v) Then
22      dic(v) = dic(v) + 1
23    Else
24      dic.Add v, 1
25    End If
26  Next i
27  
28  For i = 0 To dic.Count - 1
29    MsgBox dic.Keys(i) & "は" & dic.Items(i) & "個"
30  Next i
31  
32  Set dic = Nothing
33
34End Sub
35
36Private Function GetMaxRow(sht As Worksheet, check_col As Long) As Long
37
38  Dim lastRow As Long
39  lastRow = sht.UsedRange.Row + sht.UsedRange.Rows.Count - 1
40  GetMaxRow = 0
41    
42  Dim readRow As Long
43  For readRow = lastRow To 1 Step -1
44    If sht.Cells(readRow, check_col).Value <> "" Then
45      GetMaxRow = readRow
46      Exit For
47    End If
48  Next
49
50End Function
51
52Public Sub TestCountItem()
53  
54  Dim sht As Worksheet
55  Set sht = ThisWorkbook.Worksheets("Sheet1")
56  
57  Call CountItem(sht, 1)
58  
59  Set sht = Nothing
60  
61End Sub

1りんごは4個
2レタスは3個
3牛肉は2個
4水は1個