【VBA】連想配列(二次元もどき)でキーごとに集計を行う
<機能>
(1)VBAの連想配列でキー文字列ごとに集計を行います
(2)二次元もどきの連想配列で集計項目2つを同時に処理します
(3)過去3年間のプロ野球ペナントレースでの勝ち数、負け数を集計します
(4)連想配列メソッド(Add/Count/exists/Keys/Items)のサンプルを掲載
<動作検証&開発環境>
Microsoft Office 2010
<使い方>
適当なところにソースを張り付けて「二次元もどき連想配列で集計処理を行う()」を呼び出してください
<イメージ>
二次元もどき連想配列を用いてチーム名をキーとして、2つの項目(勝ち数、負け数)を同時に集計を行います
イミディエイトウィンドウに連想配列メソッドのサンプル実行結果を出力します
※ウィンドウが表示されていない場合はVBEの 表示 → イミディエイトウィンドウ で表示できます
'********************************************
'連想配列を使用してVBAで集計処理を行います
'疑似二次元配列で集計します
'プロ野球の過去3年間(2013-2015)のチーム毎の勝ち数、負け数を集計します
'********************************************
Sub 二次元もどき連想配列で集計処理を行う()
Dim gyo As Long, lastgyo As Long
Dim skey As String
Dim i As Integer
Dim arkey As Variant
'//全て(数式、文字列、書式、コメント、アウトライン)クリア
Cells.Select
Selection.Clear
Selection.ColumnWidth = 10
Selection.RowHeight = 19
Selection.Font.Name = "MS ゴシック"
Selection.Font.Size = 12
Columns("B").ColumnWidth = 30
Range("A1").Select
'//テスト用のサンプルデータをシートにセット
SetTestData
'//データの入っている最終行を取得
lastgyo = Range("A65536").End(xlUp).Row
'//データ有無(最低1シーズン分のデータが存在)を判定
If lastgyo < 8 Then
MsgBox "データがありません", vbExclamation
Exit Sub
End If
'//連想配列を2つ用意
'//Dim dic as New Dictionary で宣言する場合は
'//[ツール]→[参照設定]で Microsoft Scripting Runtime にチェックを入れてください
Set dic1 = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
'//チーム毎に勝ち数・負け数を集計(3列目と4列目を集計)
For gyo = 2 To lastgyo
'連想配列なので数値以外(チーム名)をインデックスに配列を作成
skey = Cells(gyo, 2).Value
'勝ち数を集計
dic1(skey) = dic1(skey) + CInt(Cells(gyo, 3).Value)
'負け数を集計(疑似二次元配列)
dic2(skey) = dic2(skey) + CInt(Cells(gyo, 4).Value)
Next
'//シートに項目行を出力する
Columns(6).ColumnWidth = 30
Columns(7).ColumnWidth = 15
Columns(8).ColumnWidth = 15
Cells(1, 6).Value = "チーム名"
Cells(1, 7).Value = "3年間の勝ち数"
Cells(1, 8).Value = "3年間の負け数"
'//連想配列のキーの要素を取得
'//dic2から取得しても同じ
arkey = dic1.Keys
'//シートに勝ち数の結果を出力
For i = 0 To UBound(arkey)
Cells(i + 2, 6).Value = arkey(i)
Cells(i + 2, 7).Value = dic1.Item(arkey(i))
Cells(i + 2, 8).Value = dic2.Item(arkey(i))
Next
Set dic1 = Nothing
Set dic2 = Nothing
'///// ここから参考 連想配列のメソッド /////
'//(参考)連想配列のメソッド
Set dic = CreateObject("Scripting.Dictionary")
Dim ar1 As Variant, ar2 As Variant
Dim j As Integer
'//(1)配列に要素を追加
dic.Add "犬", "ワンワン"
dic.Add "ねこ", "ニャー"
dic.Add "牛", "モーモー"
'//(2)要素数を取得
Debug.Print "連想配列の要素数:" & CStr(dic.Count)
'//(3)キーに対応するアイテムが存在するか判定する(True/False)
If dic.exists("ねこ") Then Debug.Print "キー「ねこ」は存在します"
If Not dic.exists("馬") Then Debug.Print "キー「馬」は存在しません"
'//(4)キーに対応するアイテムを取得する
Debug.Print "ねこは「" & dic.Item("ねこ") & "と鳴きます"
'//(5)要素を削除する
dic.Remove "ねこ"
If Not dic.exists("ねこ") Then Debug.Print "キー「ねこ」は存在しません"
'//(6)KeyとItemの一覧を取得する
artest1 = dic.Keys
artest2 = dic.Items
For j = 0 To UBound(artest1)
Debug.Print artest1(j) & "は「" & artest2(j) & "と鳴きます"
Next
Set dic = Nothing
End Sub
'********************************************
'テスト用のCSVファイルをシートに展開
'カラム1:年度
'カラム2:チーム名
'カラム3:勝ち数
'カラム4:負け数
'********************************************
Private Sub SetTestData()
Dim ar As Variant
Dim wkStr() As String
Dim i As Integer
ar = Array("年度,チーム名,勝ち数,負け数,", _
"2015,東京ヤクルトスワローズ,76,65,", "2015,読売ジャイアンツ,75,67,", _
"2015,阪神タイガース,70,71,", "2015,広島東洋カープ,69,71,", _
"2015,中日ドラゴンズ,62,77,", "2015,横浜DeNAベイスターズ,62,80,", _
"2015,福岡ソフトバンクホークス,90,49,", "2015,北海道日本ハムファイターズ,79,62,", _
"2015,千葉ロッテマリーンズ,73,69,", "2015,埼玉西武ライオンズ,69,69,", _
"2015,オリックス・バファローズ,61,80,", "2015,東北楽天ゴールデンイーグルス,57,83,", _
"2014,読売ジャイアンツ,82,61,", "2014,阪神タイガース,75,68,", _
"2014,広島東洋カープ,74,68,", "2014,中日ドラゴンズ,67,73,", _
"2014,横浜DeNAベイスターズ,67,75,", "2014,東京ヤクルトスワローズ,60,81,", _
"2014,福岡ソフトバンクホークス,78,60,", "2014,オリックス・バファローズ,80,62,", _
"2014,北海道日本ハムファイターズ,73,68,", "2014,千葉ロッテマリーンズ,66,76,", _
"2014,埼玉西武ライオンズ,63,77,", "2014,東北楽天ゴールデンイーグルス,64,80,", _
"2013,読売ジャイアンツ,84,53,", "2013,阪神タイガース,73,67,", _
"2013,広島東洋カープ,69,72,", "2013,中日ドラゴンズ,64,77,", _
"2013,横浜DeNAベイスターズ,64,79,", "2013,東京ヤクルトスワローズ,57,83,", _
"2013,東北楽天ゴールデンイーグルス,82,59,", "2013,埼玉西武ライオンズ,74,66,", _
"2013,千葉ロッテマリーンズ,74,68,", "2013,福岡ソフトバンクホークス,73,69,", _
"2013,オリックス・バファローズ,66,73,", "2013,北海道日本ハムファイターズ,64,78,")
For i = 0 To UBound(ar)
wkStr = Split(ar(i), ",")
Cells(i + 1, 1).Value = wkStr(0)
Cells(i + 1, 2).Value = wkStr(1)
Cells(i + 1, 3).Value = wkStr(2)
Cells(i + 1, 4).Value = wkStr(3)
Next
End Sub
よろしければポチッと押してください