重複の有るリストから各要素数をカウントするマクロ

今宵もExcelマクロのお勉強

今回は『重複の有るリストから各要素数をカウントするマクロ』です

果たして、聞いただけでは何をするマクロなのかよくわからない可能性があるので、早速本題へ

先ずはこちらを見て欲しい

エクセルではよくありがち？なリスト

項目に「氏名・所属・出身県・年齢・サークル」が存在しております

そして、「あ～の」さんまでがリスト化されております

今回ここでやりたいのは、じゃあ各県別の出身者数はどれくらい？

たとえば、福岡県出身の人の数は？熊本県出身の人の数は？と聞かれた場合

営業部は何人？人事部は何人？とかとか

一番原始的は方法は、目視で一つ一つ数えていくこと

少しスマートなやり方になると、フィルターをかける方法とかある

もちろん画像のような26行しかないリストなら目視で数えてもいいのでしょう

しかし、これが数百行、数千行に及んだら？目視で数えていくことは現実的ではありません

フィルターをかけるにしろ、要素数が多いとその分時間がかかります

そんなときは、Excelマクロにおまかせ！ボタン一つであら不思議

勝手に数えてくれちゃいます( *´艸｀)めんどくさい仕事はExcelにおしつけちゃいましょうね～

【使い方】

①数えたい項目にカーソルを合わせます

②マクロを実行します

③終わり

あら簡単！(/・ω・)/

出身県で実行した結果

所属で実行した結果

この通り、各要素別に数をカウントしてくれます

今回は結果の出力を【MsgBox】で行っておりますが、MsgBoxは正直オススメではありません

実際は数えた後、表にしたり、別のデータとしてリスト化したりするだろうからである

個人的にオススメなのは、ユーザーフォームのテキストボックスに出力するやり方

これなら、結果をコピーすることが可能なので、2次データとして扱いやすいです

しかし、ここではユーザーフォームの説明はしません(*'ω'*)

サークルで実行した結果が少し特殊

ご覧の通り、未所属（空欄セル）もカウントします

これは最終行の取得が上から下に見るのではなく、下から上にみた結果の賜物

ところが弱点もあります

詳しく説明はしませんが、わかるひとにはわかると信じたいと思います

万が一、使われる人がいるかもしれないので、少し仕様

・複数セル選択しているときは実行できません

・カウントは選択しているセルから下方向に行われます。上方向は無視されます

・30万行以上あるリストでは動きません

・結果の出力はMsgBoxで行っておりますが、何か別の方法にしたほうがよさげ

以上、要素数をカウントするマクロでした(*'ω'*)

Sub Count()

 

    Dim SelRow As Long
    Dim SelCol As Long
    Dim MaxRow As Long
   
    Dim Dict As Object
    Dim buf As String
    Dim KeyAll
    Dim Cnt As Long
    Dim ResultStr As String

 

    If Selection.Count <> 1 Then
        MsgBox "複数セルが選択されています。選択可能なセルは単一セルのみです。"
        Exit Sub
    Else
        SelRow = Selection.row
        SelCol = Selection.Column
    End If
   
    MaxRow = Cells(Rows.Count, SelCol).End(xlUp).row
   
    If MaxRow = 1 Or MaxRow > 300000 Then
        MsgBox "行数が多すぎるか、不正です。確認してください。"
        Exit Sub
    End If
   
    Set Dict = CreateObject("Scripting.Dictionary")
   
    For i = SelRow To MaxRow
        buf = Cells(i, SelCol).Value
        If Not Dict.Exists(buf) Then
            Dict.Add buf, buf
        End If
    Next i
   
    KeyAll = Dict.keys
   
    For j = 0 To UBound(KeyAll)
    Cnt = 0
        For k = SelRow To MaxRow
            If Cells(k, SelCol).Text = KeyAll(j) Then
                Cnt = Cnt + 1
            End If
        Next k
       
        ResultStr = ResultStr + KeyAll(j) & vbTab & Cnt & vbCrLf
       
    Next j

 

    MsgBox ResultStr
   
End Sub