全セルを対象とする場合
シートに入力されているセルの中で、同じ値が設定されているものがいくつあるのかを調べたい場合があります。
例えばA列に上から順にこのような値が設定されている場合に、「あああ」が３つ、「いいい」が２つ、ということが知りたい場合です。
列が固定されていればまだ目視でもなんとかなりそうですが、以下のようにシートのいろんな箇所にある場合は数えるのが大変です。
以下でシートの入力されているセルの同じ値がいくつあるのかを数えるコードを紹介します。
なお、以下のコードではDictionaryクラスを利用するため事前設定が必要です。
事前設定
以下のソースコードは連想配列のDictionaryクラスを利用しています。
VBA画面のツールメニュー→参照設定でMicrosoft Scripting Runtimeにチェックを付けておく必要があります。
コード
アクティブシートの入力セルを確認して、同じ値のセルの値と、そのセルの数を数えて新規シートに出力する関数です。
A列にセルの値、B列にそのセルの数を出力します。
UsedRangeプロパティを使ってシートの入力範囲のみを処理するため高速に動作します。
また、入力範囲内にある空白セルもカウント対象になります。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 |
Sub CountSameCell() Dim r As Range Dim d As New Dictionary Dim i Dim keyAll Dim v For Each r In ActiveSheet.UsedRange '// Dictionaryに未登録の場合 If d.Exists(r.Value) = False Then '// カウントを1で初期化 i = 1 '// Dictionaryに登録済みの場合 Else '// Dictionaryから登録済みの現在セル値のカウントを取得 i = d.Item(r.Value) '// カウントを1増やす i = i + 1 '// 一時的にDictionaryから削除 Call d.Remove(r.Value) End If '// Dictionaryに追加 Call d.Add(r.Value, i) Next '// 結果出力用に新規シートを追加 Call Worksheets.Add '// Dictionaryの全キーを取得 keyAll = d.Keys '// 全キーをループ For i = 0 To UBound(keyAll) v = d.Item(keyAll(i)) ActiveCell.Offset(i, 0).Value = keyAll(i) ActiveCell.Offset(i, 1).Value = v Next End Sub |
実行例
上のあああ、いいい、うううのシートをアクティブにして上の関数を実行すると以下のように新規シートに出力されます。
