Excel VBA 連想配列(ハッシュ テーブル)

Excel VBA のトップに戻る
Excel VBA 目次

基本操作
日本語変数と、Excelの計算式を記述
OSのバージョンとExcelのバージョンを取得
IE のバージョンを取得
データを並び替え
大量データを照合
ソートして順位(ランク)を設定
二次元配列ソート(Access データベースをシーケンシャルに更新する)
連想配列を使って検索を高速化する
 ・シーザー暗号(換字暗号)
 ・文字の出現頻度を数える
 ・品目マスタと照合
 ・Dictionary オブジェクトと Collection オブジェクト

索引


連想配列を使って検索を高速化する

 配列を使って、順次検索して照合する方法だと、データ件数が多くなると、相応して時間がかかります。
うまいやり方がないかと調べていて「連想配列(ハッシュ テーブル)」の存在を知りました。
 下記サイトで、VBA での「連想配列」の使い方が、分かりやすく書かれていました。

 VBAで連想配列 〜 Scripting.Dictionary
http://www.niji.or.jp/home/toru/notes/17.html

 上のサイトで教えていただいた方法を、マクロに応用したら、処理速度が10倍以上、速くなりました。目からうろこ、大感激です。

 Dictionay オブジェクト は、Item番号を付けて、データ(要素、Items)とキー(Keys)をセットで、格納します。
 キーは、整数だけでなく、文字列などを指定できますが、重複させることはできません。
 Item 1〜の番号は、キーを追加するときに、自動的に設定されます。
 Dictionay オブジェクトを使うと、キーに対するデータを瞬時に取り出すことができるだけでなく、キーの存在チェック も、簡単にできます。

 注意:Dictionay オブジェクトの「Item番号」からキーを取得できません。取得しようとすると、Empty となります。
 このため、Dictionay オブジェクトの Keys メソッド を使って配列に書き出しておいて、この配列から取り出します。

シーザー暗号(換字暗号)

 幼稚園の子供たちの間で、五十音表(かな・カナ) を用いた シーザー暗号(換字暗号) が流行している、と聞きました。
 シーザー暗号とは、音表で文字数を決めて、元の文章の文字を、その文字数だけずらす(・・・)ものです。
そこで、この暗号の、エンコード・デコードをするマクロを作ってみました。
 五十音表を引くところを Dictionary オブジェクト を使って高速化しています。

 暗号ではありませんが「2001年宇宙の旅」に出てくる AI コンピュータの名前「HAL」は、コンピュータ・メーカの IBM の文字を、I→H B→A M→L と、1文字分だけ前に ずらした(・・・・) ものと言われています。

 シーザー暗号
https://ja.wikipedia.org/wiki/%E3%82%B7%E3%83%BC%E3%82%B6%E3%83%BC%E6%9A%97%E5%8F%B7
 サルにも分かるRSA暗号
http://www.maitou.gr.jp/rsa/rsa03.php
 換字暗号について
http://www.comm.tcu.ac.jp/~math/hnakai/infomath/substitutioncipher.html

このマクロをダウンロードできます。CaesarCipherUsingJapaneseSyllabaryVBA02.xls

単純配列版
Option Explicit

   Dim 五十音索引 As Object         'Scripting.Dictionary オブジェクト
   Dim 五十音配列()
   Dim 文字列 As String
   Dim 文字数 As Integer
   Dim 位置 As Integer
   Dim 文字 As String
   Dim 変更後文字列 As String

Sub 後ろの文字に変換()

   Call 五十音表
   
   Worksheets("後ろへ前へ").Activate
   
   変更後文字列 = ""
   文字列 = Range("C1").Value
   文字数 = Len(文字列)
   
   If 文字数 > 0 Then
      For 位置 = 1 To 文字数
         文字 = Mid(文字列, 位置, 1)
'         Stop
         If 五十音索引.Exists(文字) = True Then
            変更後文字列 = 変更後文字列 & 五十音配列(五十音索引(文字) + 1)
         Else
            変更後文字列 = 変更後文字列 & 文字
         End If
      Next 位置
   
   End If
   
   Range("C3").Value = 変更後文字列
End Sub


Sub 前の文字に変換()

   Call 五十音表
   
   Worksheets("後ろへ前へ").Activate
   変更後文字列 = ""
   文字列 = Range("C3").Value
   文字数 = Len(文字列)
   
   If 文字数 > 0 Then
      For 位置 = 1 To 文字数
         文字 = Mid(文字列, 位置, 1)
'         Stop
         If 五十音索引.Exists(文字) = True Then
            変更後文字列 = 変更後文字列 & 五十音配列(五十音索引(文字) - 1)
         Else
            変更後文字列 = 変更後文字列 & 文字
         End If
      Next 位置
   
   End If
   
   Range("C5").Value = 変更後文字列
End Sub


Private Sub 五十音表()

   Dim 処理行 As Integer
   Dim 文字 As String
   Dim カウンタ As Integer
   
   '★文字索引を作成★
   Set 五十音索引 = CreateObject("Scripting.Dictionary")               '★連想配列の定義
   
   For 処理行 = 2 To 146
      文字 = Worksheets("50音表").Range("A1").Cells(処理行, 1).Value   '五十音の文字
      五十音索引(文字) = カウンタ
      カウンタ = カウンタ + 1
      'ここで同時に「五十音配列」に登録することも考えられます。
      'しかし、誤ってキーデータに重複があると、五十音索引の登録は後のデータで上書きされてしまいます。
      'このため、五十音索引と五十音配列に乖離が生じます。
      'キーに重複が無いことが確実でない限り、keys メソッドを使って事後書き出ししたほうが安全です。
   Next 処理行
   
   五十音配列 = 五十音索引.keys

End Sub

この種類の目次に戻る↑ 索引へ↓ トップページに戻る
上の単純配列版では、五十音を一つの表にしてずらしていました。
下のバージョンは、ひらがな、カタカナについて、それぞれ、清音、濁音、半濁音、捨て仮名(小文字)を区分して、その範囲内毎に文字をずらしています。

このマクロをダウンロードできます。CaesarCipherUsingJapaneseSyllabaryVBA20.xls

Option Explicit

   Dim かな索引 As Object         'Scripting.Dictionary オブジェクト
   Dim かな配列()
   Dim カタカナ索引 As Object     'Scripting.Dictionary オブジェクト
   Dim カタカナ配列()
   Dim だく音索引 As Object       'Scripting.Dictionary オブジェクト
   Dim だく音配列()
   Dim ダクオン索引 As Object     'Scripting.Dictionary オブジェクト
   Dim ダクオン配列()
   Dim 半だく索引 As Object       'Scripting.Dictionary オブジェクト
   Dim 半だく配列()
   Dim ハンダク索引 As Object     'Scripting.Dictionary オブジェクト
   Dim ハンダク配列()
   Dim 捨て仮名索引 As Object     'Scripting.Dictionary オブジェクト
   Dim 捨て仮名配列()
   Dim ステガナ索引 As Object     'Scripting.Dictionary オブジェクト
   Dim ステガナ配列()

   Dim 文字列 As String
   Dim 文字数 As Integer
   Dim 位置 As Integer
   Dim 文字 As String
   Dim 変更後文字列 As String

Sub 後ろの文字に変換()

   Call 五十音表
   
   Worksheets("後ろへ前へ").Activate
   
   変更後文字列 = ""
   文字列 = Range("C1").Value
   文字数 = Len(文字列)
   
   If 文字数 > 0 Then
      For 位置 = 1 To 文字数
         文字 = Mid(文字列, 位置, 1)
'         Stop
         If かな索引.Exists(文字) = True Then
            If かな索引(文字) = かな索引.Count Then
               変更後文字列 = 変更後文字列 & かな配列(0)
            Else
               変更後文字列 = 変更後文字列 & かな配列(かな索引(文字))
            End If
         ElseIf カタカナ索引.Exists(文字) = True Then
            If カタカナ索引(文字) = カタカナ索引.Count Then
               変更後文字列 = 変更後文字列 & カタカナ配列(0)
            Else
               変更後文字列 = 変更後文字列 & カタカナ配列(カタカナ索引(文字))
            End If
         ElseIf だく音索引.Exists(文字) = True Then
            If だく音索引(文字) = だく音索引.Count Then
               変更後文字列 = 変更後文字列 & だく音配列(0)
            Else
               変更後文字列 = 変更後文字列 & だく音配列(だく音索引(文字))
            End If
         ElseIf ダクオン索引.Exists(文字) = True Then
            If ダクオン索引(文字) = ダクオン索引.Count Then
               変更後文字列 = 変更後文字列 & ダクオン配列(0)
            Else
               変更後文字列 = 変更後文字列 & ダクオン配列(ダクオン索引(文字))
            End If
         ElseIf 半だく索引.Exists(文字) = True Then
            If 半だく索引(文字) = 半だく索引.Count Then
               変更後文字列 = 変更後文字列 & 半だく配列(0)
            Else
               変更後文字列 = 変更後文字列 & 半だく配列(半だく索引(文字))
            End If
         ElseIf ハンダク索引.Exists(文字) = True Then
            If ハンダク索引(文字) = ハンダク索引.Count Then
               変更後文字列 = 変更後文字列 & ハンダク配列(0)
            Else
               変更後文字列 = 変更後文字列 & ハンダク配列(ハンダク索引(文字))
            End If
         ElseIf 捨て仮名索引.Exists(文字) = True Then
            If 捨て仮名索引(文字) = 捨て仮名索引.Count Then
               変更後文字列 = 変更後文字列 & 捨て仮名配列(0)
            Else
               変更後文字列 = 変更後文字列 & 捨て仮名配列(捨て仮名索引(文字))
            End If
         ElseIf ステガナ索引.Exists(文字) = True Then
            If ステガナ索引(文字) = ステガナ索引.Count Then
               変更後文字列 = 変更後文字列 & ステガナ配列(0)
            Else
               変更後文字列 = 変更後文字列 & ステガナ配列(ステガナ索引(文字))
            End If
         Else
            変更後文字列 = 変更後文字列 & 文字
         End If
      Next 位置
   
   End If
   
   Range("C3").Value = 変更後文字列
End Sub


Sub 前の文字に変換()

   Call 五十音表
   
   Worksheets("後ろへ前へ").Activate
   変更後文字列 = ""
   文字列 = Range("C3").Value
   文字数 = Len(文字列)
   
   If 文字数 > 0 Then
      For 位置 = 1 To 文字数
         文字 = Mid(文字列, 位置, 1)
'         Stop

         If かな索引.Exists(文字) = True Then
            If かな索引(文字) = 1 Then
               変更後文字列 = 変更後文字列 & かな配列(かな索引.Count - 1)
            Else
               変更後文字列 = 変更後文字列 & かな配列(かな索引(文字) - 2)
            End If
         ElseIf カタカナ索引.Exists(文字) = True Then
            If カタカナ索引(文字) = 1 Then
               変更後文字列 = 変更後文字列 & カタカナ配列(カタカナ索引.Count - 1)
            Else
               変更後文字列 = 変更後文字列 & カタカナ配列(カタカナ索引(文字) - 2)
            End If
         ElseIf だく音索引.Exists(文字) = True Then
            If だく音索引(文字) = 1 Then
               変更後文字列 = 変更後文字列 & だく音配列(だく音索引.Count - 1)
            Else
               変更後文字列 = 変更後文字列 & だく音配列(だく音索引(文字) - 2)
            End If
         ElseIf ダクオン索引.Exists(文字) = True Then
            If ダクオン索引(文字) = 1 Then
               変更後文字列 = 変更後文字列 & ダクオン配列(ダクオン索引.Count - 1)
            Else
               変更後文字列 = 変更後文字列 & ダクオン配列(ダクオン索引(文字) - 2)
            End If
         ElseIf 半だく索引.Exists(文字) = True Then
            If 半だく索引(文字) = 1 Then
               変更後文字列 = 変更後文字列 & 半だく配列(半だく索引.Count - 1)
            Else
               変更後文字列 = 変更後文字列 & 半だく配列(半だく索引(文字) - 2)
            End If
         ElseIf ハンダク索引.Exists(文字) = True Then
            If ハンダク索引(文字) = 1 Then
               変更後文字列 = 変更後文字列 & ハンダク配列(ハンダク索引.Count - 1)
            Else
               変更後文字列 = 変更後文字列 & ハンダク配列(ハンダク索引(文字) - 2)
            End If
         ElseIf 捨て仮名索引.Exists(文字) = True Then
            If 捨て仮名索引(文字) = 1 Then
               変更後文字列 = 変更後文字列 & 捨て仮名配列(捨て仮名索引.Count - 1)
            Else
               変更後文字列 = 変更後文字列 & 捨て仮名配列(捨て仮名索引(文字) - 2)
            End If
         ElseIf ステガナ索引.Exists(文字) = True Then
            If ステガナ索引(文字) = 1 Then
               変更後文字列 = 変更後文字列 & ステガナ配列(ステガナ索引.Count - 1)
            Else
               変更後文字列 = 変更後文字列 & ステガナ配列(ステガナ索引(文字) - 2)
            End If
         Else
            変更後文字列 = 変更後文字列 & 文字
         End If
      Next 位置
   
   End If
   
   Range("C5").Value = 変更後文字列
End Sub


Private Sub 五十音表()

   Dim 処理行 As Integer
   Dim 文字 As String
   Dim カウンタ As Integer
   Dim 最終行 As Integer
   Dim 処理列 As Integer
   
   '★文字索引を作成★
   Set かな索引 = CreateObject("Scripting.Dictionary")               '★連想配列の定義
   Set カタカナ索引 = CreateObject("Scripting.Dictionary")           '★連想配列の定義
   Set だく音索引 = CreateObject("Scripting.Dictionary")             '★連想配列の定義
   Set ダクオン索引 = CreateObject("Scripting.Dictionary")           '★連想配列の定義
   Set 半だく索引 = CreateObject("Scripting.Dictionary")             '★連想配列の定義
   Set ハンダク索引 = CreateObject("Scripting.Dictionary")           '★連想配列の定義
   Set 捨て仮名索引 = CreateObject("Scripting.Dictionary")           '★連想配列の定義
   Set ステガナ索引 = CreateObject("Scripting.Dictionary")           '★連想配列の定義
   
   Worksheets("50音表").Activate
   For 処理列 = 2 To 9
      最終行 = Cells(ActiveSheet.Rows.Count, 処理列).End(xlUp).Row
      カウンタ = 0
      For 処理行 = 2 To 最終行
         文字 = Range("A1").Cells(処理行, 処理列).Value   '五十音の文字
         カウンタ = カウンタ + 1
         Select Case 処理列
            Case 2
               かな索引(文字) = カウンタ
            Case 3
               カタカナ索引(文字) = カウンタ
            Case 4
               だく音索引(文字) = カウンタ
            Case 5
               ダクオン索引(文字) = カウンタ
            Case 6
               半だく索引(文字) = カウンタ
            Case 7
               ハンダク索引(文字) = カウンタ
            Case 8
               捨て仮名索引(文字) = カウンタ
            Case 9
               ステガナ索引(文字) = カウンタ
         End Select
         
      'ここで同時に「五十音配列」に登録することも考えられます。
         'しかし、誤ってキーデータに重複があると、五十音索引の登録は後のデータで上書きされてしまいます。
         'このため、五十音索引と五十音配列に乖離が生じます。
         'キーに重複が無いことが確実でない限り、keys メソッドを使って事後書き出ししたほうが安全です。
      Next 処理行
  
   Next 処理列
   
   かな配列 = かな索引.keys             '配列の添え字は 0 で始まる。Option Base 1 は効かない
   カタカナ配列 = カタカナ索引.keys
   だく音配列 = だく音索引.keys
   ダクオン配列 = ダクオン索引.keys
   半だく配列 = 半だく索引.keys
   ハンダク配列 = ハンダク索引.keys
   捨て仮名配列 = 捨て仮名索引.keys
   ステガナ配列 = ステガナ索引.keys
'Stop
End Sub

この種類の目次に戻る↑ 索引へ↓ トップページに戻る


文字の出現頻度を数える

 上で紹介した シーザー暗号 は、文字を他の文字に置き換えるものでしたが、換字暗号には、文字を他の記号に置き換えるものも、あります。

 探偵小説 シャーロック・ホームズシリーズの「踊る人形」 の暗号は、換字暗号の一つです。

 小説の中で、シャーロック・ホームズ は、英文中の文字の出現頻度から、「踊る人形」の暗号を解読します。
 「踊る人形」の解読方法
http://www.comm.tcu.ac.jp/~math/hnakai/infomath/sherlockholmes/dance_decording.html

 そこで、適当な長さの文章を指定して、文中に使われている文字の出現頻度を調べるマクロを、紹介します。
 これは、Dictionary オブジェクト の典型的な使い方をデモする、プログラム例です。

このマクロをダウンロードできます。CountTheNumberOfOccurrencesOfCharactersVBA01.xls

Sub 文字の出現頻度を数える()

   Dim 文字列 As String
   Dim 文字数 As Integer
   Dim 総文字数 As Integer
   Dim 文字 As String
   Dim 位置 As Integer
   Dim 文字索引 As Object         'Scripting.Dictionary オブジェクト
   Dim 文字配列()
   Dim 計数配列()
   Dim 最終行 As Integer
   Dim 最終列 As Integer
   Dim 行数 As Integer
   Dim 列数 As Integer
   
   '★文字索引を作成★
   Set 文字索引 = CreateObject("Scripting.Dictionary")  '★連想配列の定義
   
   ThisWorkbook.Worksheets("調べたい文字列").Activate
   
'   教えていただいたサイト
'   http://www.niji.or.jp/home/toru/notes/8.html
   With ActiveSheet.UsedRange
      最終行 = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
      最終列 = .Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
   End With
   
   文字数 = 0
   総文字数 = 0

   For 行数 = 1 To 最終行
      For 列数 = 1 To 最終列

         文字列 = Range("A1").Cells(行数, 列数)
         文字数 = Len(文字列)
         総文字数 = 総文字数 + 文字数
         
         For 位置 = 1 To 文字数
            文字 = Mid(文字列, 位置, 1)
            If Trim(文字) <> "" Then
               If 文字 = "'" Then 文字 = "''"     'セルに貼り付けたとき見えるように
               If 文字 = "’" Then 文字 = "'’"   'セルに貼り付けたとき見えるように
               If 文字索引.Exists(文字) = True Then
                  文字索引(文字) = 文字索引(文字) + 1
               Else
                  文字索引(文字) = 1
               End If
            End If
         Next 位置
      Next 列数
   Next 行数
   
   文字配列 = 文字索引.Keys
   計数配列 = 文字索引.Items

   '上で取得した配列は 1次元のため、行方向の 2次元配列に変換する。
   文字配列 = WorksheetFunction.Transpose(文字配列)
   計数配列 = WorksheetFunction.Transpose(計数配列)
   
   ThisWorkbook.Worksheets("起動画面").Activate
   Columns("A:B").Clear
   Range("A1").Value = "文字"
   Range("B1").Value = "出現回数"

   Range("A2").Resize(文字索引.Count, 1) = 文字配列
   Range("B2").Resize(文字索引.Count, 1) = 計数配列
   
   Range("A1").CurrentRegion.Sort _
   Key1:=Range("B1"), Order1:=xlDescending, _
   Header:=xlYes
      
   MsgBox ("総文字数= " & 総文字数)
End Sub


この種類の目次に戻る↑ 索引へ↓ トップページに戻る

品目マスタと照合


 下の例は、商社が、ユーザから受けた「注文リスト(10,000件)」を、「仕入先」別に仕分けして、「品目コード」単位に数量まとめした「集計リスト」を作成する処理の例です。
 「注文リスト」は、「品目マスタ(15,000件)」と照合して、「単価」や「仕入先」を設定します。
 「注文リスト」と「品目マスタ」を、順次処理で照合すると、10,000件×15,000件/2=7千5百万回 の照合作業が発生します。これでは、いくらパソコンの速度が速くても、それなりの時間がかかってしまいます。
 「連想配列」を使って、「品目コード」に索引を付けると、直接アクセスできるので、飛躍的に速くなりました。

このマクロをダウンロードできます。DictionaryVBA01.xls

 Dictionaryオブジェクトの使い方については、下記も参考になります。

 Excel(エクセル) VBA入門:Dictionaryオブジェクトを利用する
http://www.eurus.dti.ne.jp/yoneyama/Excel/vba/vba_dictionary.html
 Excel VBA スキルアップコレクション 連想配列を作成する
http://bookdiary.livedoor.biz/archives/51624011.html
 1つのキー文字列に対して複数の文字列値を保持するには?
http://www.atmarkit.co.jp/ait/articles/0505/27/news117.html
 VBAでクラスをつくる
https://qiita.com/Kamo123/items/a4c7749fa30d8f68df28


Option Explicit
Option Base 1

   Dim 品目マスタ配列() As Variant
   Dim 品目マスタ件数 As Integer
   Dim 注文リスト配列() As Variant
   Dim 注文リスト件数 As Integer
   Dim 注文集計配列(10000, 8) As Variant
   Dim 集計品目件数 As Integer
   Dim 処理行 As Integer
   Dim 開始日時 As Variant
   Dim 終了日時 As Variant
   Dim エラー配列(5000, 2) As Variant
   Dim エラー件数 As Integer
   Dim 品目コード As String
      
Sub 発注仕分け連想配列版()

   Dim 品目マスタ索引 As Object        'Scripting.Dictionary オブジェクト
   Dim 品目マスタ配列添え字 As Integer 'Scripting.Dictionary オブジェクトのデータ

   Dim 注文集計索引 As Object          'Scripting.Dictionary オブジェクト
   Dim 注文集計配列添え字 As Integer   'Scripting.Dictionary オブジェクトのデータ
   
   開始日時 = Now                      '開始時刻を変数に格納します。

   Call 注文リスト読み込み
   Call 品目マスタ読み込み
   
   '★品目マスタ索引を作成★
   Set 品目マスタ索引 = CreateObject("Scripting.Dictionary")  '★連想配列の定義
   For 処理行 = 2 To 品目マスタ件数 + 1
      品目コード = 品目マスタ配列(処理行, 1)                  '品目コード
      品目マスタ索引(品目コード) = 処理行
   Next 処理行
   
   '集計作業
   Set 注文集計索引 = CreateObject("Scripting.Dictionary")    '★連想配列の定義
   
   集計品目件数 = 0
   エラー件数 = 0
   For 処理行 = 2 To 注文リスト件数 + 1
      品目コード = 注文リスト配列(処理行, 1)
      If 品目マスタ索引.Exists(品目コード) = True Then
         '★品目マスタに存在した場合
         品目マスタ配列添え字 = 品目マスタ索引(品目コード)
         
         If 集計品目件数 = 0 Then '一件目の注文品目
            集計品目件数 = 集計品目件数 + 1
            注文集計配列(集計品目件数, 1) = 品目マスタ配列(品目マスタ配列添え字, 2)    '仕入先
            注文集計配列(集計品目件数, 2) = 品目コード                             '品目コード
            注文集計配列(集計品目件数, 3) = 注文リスト配列(処理行, 2)                  '数量
            注文集計配列(集計品目件数, 4) _
            = 品目マスタ配列(品目マスタ配列添え字, 3) * 注文集計配列(集計品目件数, 3)  '金額
            注文集計配列(集計品目件数, 5) _
            = 品目マスタ配列(品目マスタ配列添え字, 4) * 注文集計配列(集計品目件数, 3)  '重量

            注文集計索引(品目コード) = 集計品目件数  '★既存品目として索引に追加

         Else                    '二件目以降の注目品目
            '既存チェック
            If 注文集計索引.Exists(品目コード) = True Then
               '既存の場合、数量のみ足し込む
               注文集計配列添え字 = 注文集計索引(品目コード)
               注文集計配列(注文集計配列添え字, 3) _
               = 注文集計配列(注文集計配列添え字, 3) + 注文リスト配列(処理行, 2)               '数量
               注文集計配列(注文集計配列添え字, 4) _
               = 品目マスタ配列(品目マスタ配列添え字, 3) * 注文集計配列(注文集計配列添え字, 3) '金額
               注文集計配列(注文集計配列添え字, 5) _
               = 品目マスタ配列(品目マスタ配列添え字, 4) * 注文集計配列(注文集計配列添え字, 3) '重量
            Else
               '新規の場合は、配列に追加する
               集計品目件数 = 集計品目件数 + 1
               注文集計配列(集計品目件数, 1) = 品目マスタ配列(品目マスタ配列添え字, 2)    '仕入先
               注文集計配列(集計品目件数, 2) = 品目コード                           '品目コード
               注文集計配列(集計品目件数, 3) = 注文リスト配列(処理行, 2)                  '数量
               注文集計配列(集計品目件数, 4) _
               = 品目マスタ配列(品目マスタ配列添え字, 3) * 注文集計配列(集計品目件数, 3)  '金額
               注文集計配列(集計品目件数, 5) _
               = 品目マスタ配列(品目マスタ配列添え字, 4) * 注文集計配列(集計品目件数, 3)  '重量

               注文集計索引(品目コード) = 集計品目件数  '★既存品目として索引に追加
            End If
         End If
      Else '品目マスタに存在しない
         エラー件数 = エラー件数 + 1
         エラー配列(エラー件数, 1) = 品目コード
         エラー配列(エラー件数, 2) = 注文リスト配列(処理行, 2)
      End If
   Next 処理行
   
   Call 結果出力
   Call エラー出力
   
   ThisWorkbook.Worksheets("スタート").Activate
   終了日時 = Now
   
   Range("F10").Value = "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"
   
   Range("F11").Value = "マスタに存在しない品目は、" _
   & エラー件数 & " でした。"
   
   MsgBox "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。" & vbNewLine _
   & "マスタに存在しない品目は、" & エラー件数 & " でした。"

End Sub


Sub 発注仕分け順処理版()

   Dim マスタ検索行 As Integer
   Dim 集計検索行 As Integer
   Dim 既存フラグ As String
   Dim マスタ存在フラグ As String

   開始日時 = Now                ' 開始時刻を変数に格納します。

   Call 注文リスト読み込み
   Call 品目マスタ読み込み
   
   '集計作業
   集計品目件数 = 0
   エラー件数 = 0
   For 処理行 = 2 To 注文リスト件数 + 1
      既存フラグ = ""
      マスタ存在フラグ = ""
      品目コード = 注文リスト配列(処理行, 1)

      For マスタ検索行 = 2 To 品目マスタ件数 + 1
         If 品目コード = 品目マスタ配列(マスタ検索行, 1) Then
            マスタ存在フラグ = "存在"
            If 集計品目件数 = 0 Then '一件目の注文品目
               集計品目件数 = 集計品目件数 + 1
               注文集計配列(集計品目件数, 1) = 品目マスタ配列(マスタ検索行, 2)    '仕入先
               注文集計配列(集計品目件数, 2) = 品目コード                         '品目コード
               注文集計配列(集計品目件数, 3) = 注文リスト配列(処理行, 2)          '数量
               注文集計配列(集計品目件数, 4) _
               = 品目マスタ配列(マスタ検索行, 3) * 注文集計配列(集計品目件数, 3)  '金額
               注文集計配列(集計品目件数, 5) _
               = 品目マスタ配列(マスタ検索行, 4) * 注文集計配列(集計品目件数, 3)  '重量
   
            Else                    '二件目以降の注目品目
               '既存チェック
               For 集計検索行 = 1 To 集計品目件数
                  If 注文集計配列(集計検索行, 2) = 品目コード Then
                     '既存の場合、数量のみ足し込む
                     注文集計配列(集計検索行, 3) _
                     = 注文集計配列(集計検索行, 3) + 注文リスト配列(処理行, 2)       '数量
                     注文集計配列(集計検索行, 4) _
                     = 品目マスタ配列(マスタ検索行, 3) * 注文集計配列(集計検索行, 3) '金額
                     注文集計配列(集計検索行, 5) _
                     = 品目マスタ配列(マスタ検索行, 4) * 注文集計配列(集計検索行, 3) '重量
                     既存フラグ = "既存"
                     Exit For
                  End If
               Next 集計検索行
               
               If 既存フラグ = "" Then
                  '新規の場合は、配列に追加する
                  集計品目件数 = 集計品目件数 + 1
                  注文集計配列(集計品目件数, 1) = 品目マスタ配列(マスタ検索行, 2)    '仕入先
                  注文集計配列(集計品目件数, 2) = 品目コード                     '品目コード
                  注文集計配列(集計品目件数, 3) = 注文リスト配列(処理行, 2)          '数量
                  注文集計配列(集計品目件数, 4) _
                  = 品目マスタ配列(マスタ検索行, 3) * 注文集計配列(集計品目件数, 3)  '金額
                  注文集計配列(集計品目件数, 5) _
                  = 品目マスタ配列(マスタ検索行, 4) * 注文集計配列(集計品目件数, 3)  '重量
               End If
            End If
         End If
      Next マスタ検索行
      
      If マスタ存在フラグ = "" Then  '品目マスタに存在しない
         エラー件数 = エラー件数 + 1
         エラー配列(エラー件数, 1) = 品目コード
         エラー配列(エラー件数, 2) = 注文リスト配列(処理行, 2)
      End If
   Next 処理行
   
   Call 結果出力
   Call エラー出力
   
   ThisWorkbook.Worksheets("スタート").Activate
   終了日時 = Now
   
   Range("F15").Value = "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"
   
   Range("F16").Value = "マスタに存在しない品目は、" _
   & エラー件数 & " でした。"
   
   MsgBox "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。" & vbNewLine _
   & "マスタに存在しない品目は、" & エラー件数 & " でした。"
   
End Sub


Private Sub 結果出力()
   Dim 追加シート名初期 As String
   Dim 追加シート名 As String
   Dim 重複 As Integer
   Dim シート As Worksheet
   Dim シート数 As Integer
   Dim 仕入先 As String
   Dim 仕入先前 As String
   Dim 数量合計 As Long
   Dim 金額合計 As Long
   Dim 重量合計 As Long

   追加シート名初期 = "注文集計結果"
   追加シート名 = 追加シート名初期

   For 重複 = 1 To 100
   ' 100枚まで追加しても重複しないように追番を設定します。
      For Each シート In Worksheets
         If シート.Name = 追加シート名 Then
            追加シート名 = 追加シート名初期 & "(" & 重複 & ")"
         End If
      Next シート
   Next 重複
   シート数 = Worksheets.Count
   Worksheets("テンプレート").Copy After:=Worksheets(シート数)
   ActiveSheet.Name = 追加シート名
   
   Range("A2").Resize(集計品目件数, 5).Value = 注文集計配列
    
   Range("A1").CurrentRegion.Sort _
      Key1:=Range("A1"), Order1:=xlAscending, _
      Key2:=Range("B1"), Order2:=xlAscending, _
      Header:=xlYes
      
   仕入先前 = Range("A2").Value
   
   For 処理行 = 2 To 集計品目件数 + 2
      仕入先 = Range("A1").Cells(処理行, 1).Value
      If 仕入先 = 仕入先前 Then
         数量合計 = 数量合計 + Range("C1").Cells(処理行, 1).Value
         金額合計 = 金額合計 + Range("D1").Cells(処理行, 1).Value
         重量合計 = 重量合計 + Range("E1").Cells(処理行, 1).Value
      Else
         仕入先前 = 仕入先
         Range("F1").Cells(処理行 - 1, 1).Value = 数量合計
         Range("G1").Cells(処理行 - 1, 1).Value = 金額合計
         Range("H1").Cells(処理行 - 1, 1).Value = 重量合計
         
         数量合計 = Range("C1").Cells(処理行, 1).Value
         金額合計 = Range("D1").Cells(処理行, 1).Value
         重量合計 = Range("E1").Cells(処理行, 1).Value
      End If
   Next 処理行
End Sub


Private Sub エラー出力()
   Dim 追加シート名初期 As String
   Dim 追加シート名 As String
   Dim 重複 As Integer
   Dim シート As Worksheet
   Dim シート数 As Integer

   追加シート名初期 = "エラー品目"
   追加シート名 = 追加シート名初期

   For 重複 = 1 To 100
   ' 100枚まで追加しても重複しないように追番を設定します。
      For Each シート In Worksheets
         If シート.Name = 追加シート名 Then
            追加シート名 = 追加シート名初期 & "(" & 重複 & ")"
         End If
      Next シート
   Next 重複
   シート数 = Worksheets.Count
   Worksheets("エラーテンプレ").Copy After:=Worksheets(シート数)
   ActiveSheet.Name = 追加シート名
   
   Range("A2").Resize(エラー件数, 2).Value = エラー配列

End Sub


Private Sub 注文リスト読み込み()

   ThisWorkbook.Worksheets("注文リスト").Activate
   注文リスト配列 = Range("A1").CurrentRegion
   注文リスト件数 = UBound(注文リスト配列) - 1 '一行目は項目名のため除外
   
End Sub


Private Sub 品目マスタ読み込み()

   ThisWorkbook.Worksheets("品目マスタ").Activate
   品目マスタ配列 = Range("A1").CurrentRegion
   品目マスタ件数 = UBound(品目マスタ配列) - 1 '一行目は項目名のため除外
   
End Sub

 解説

 Dictionary オブジェクト は、「データ キー」と、「組みとなる項目」を格納するオブジェクトです。
 構文
 Scripting.Dictionary

注:事前にVBエディタの [ツール(T)] → [参照設定(R)] で [Microsoft Scripting Runtime] にチェックを入れておくと、
宣言 Dim 辞書 As New Dictionary が使えます。

 Dictionary オブジェクトは、PERL の関連配列と同等です。
任意の型のデータにできる項目は、配列に格納されます。
項目は、重複しないキーで関連付けられます。
キーは各項目を取得するのに使用され、通常、整数型か文字列型ですが、配列にはできません。

Dictionary オブジェクトは厳密な意味では配列ではありませんが、複数の値を保管できるデータ構造という点で、配列と類似した機能を持っています。
Dictionary オブジェクトには、For Each…Next ステートメント、With…End With ステートメントなどのオブジェクト プログラミング コンストラクトを使用した作業が可能であることや、長さを調整する必要がない、という配列を使った作業にはない利点があります。

配列の代わりに Dictionary オブジェクトを使用してデータ セットを保管する場合、Dictionary オブジェクトの Exists メソッドを呼び出し、目的のアイテムに対するキーを渡すことにより、特定のアイテムがディクショナリに存在するかどうかをすばやく調べることができます。
ただし、Exists メソッドでは、ディクショナリ内のアイテムの位置または出現回数に関する情報は返されません。

配列に対して Filter 関数を使用する方法では別の配列が返されますが、Dictionary オブジェクトに対して Exists メソッドを使用すると、ブール型 (Boolean) の値が返されるという利点があります。検索アイテムの出現回数が重要ではない場合は、Dictionary オブジェクトを使用するとコードが簡潔になります。

 MSDN ライブラリの、「ファイル システムからファイルを返す」に記載されている GetFiles プロシージャと TestGetFiles プロシージャでも、Dictionary オブジェクトの使用について説明されています。

 Dictionary オブジェクトの詳細については、MSDN ライブラリの、https://technet.microsoft.com/ja-jp/scriptcenter/ff731125★ を参照してください。

 下のコードは、Dictionary オブジェクトの作成方法の例です。

Dim d                   '変数を宣言します。
Set d = CreateObject(Scripting.Dictionary)
d.Add "a", "Athens"     'キーと項目を追加します。
d.Add "b", "Belgrade"
d.Add "c", "Cairo"
...


  Excel VBAでじゃんけんプログラム:多段ハッシュ(多段連想配列)を使った例
 http://d.hatena.ne.jp/bi_na/20100517/1274096780
 興味深い使い方の事例が、紹介されています。

 Dictionary オブジェクトのプロパティ
Count 連想配列に格納された項目の数を返します。
Item(key) キー(key)に関連付けられた項目を取り出します。
Item(key) = newitem キー(key)に新しい項目(newitem)を関連付けます。
Key(key) = newkey キー(key)を新しいキー(newkey)に置き換えます。
CompareMode vbBinaryCompare(0) … 大文字小文字を区別します。
vbTextCompare(1) … 大文字小文字を区別しません。
obj.CompareMode = vbBinaryCompare

 Item プロパティ は、Dictionary オブジェクトにある指定されたキーと関連付ける項目を設定します。
コレクションの場合、指定されたキーを基に項目を返します。値の取得も可能です。
 構文
 object.Item(key) [= newitem]

 Item プロパティの構文は、次の指定項目から構成されます。
指定項目 内容
Object 必ず指定します。Dictionary オブジェクトの名前を指定します。
Key 必ず指定します。取得または追加する項目と関連付けるキーを指定します。
Newitem 省略可能です。引数 key で指定した値と関連付ける新しい項目を指定します。

 注:.Item 部分を省略して記述することもできます。
 object(key) [= newitem]


 Key プロパティ は、Dictionary オブジェクトにキーを設定します。
値の取得も可能です。
 構文
 object.Key(key) = newkey

 Key プロパティの構文は、次の指定項目から構成されます。
指定項目 内容
object 必ず指定します。Dictionary オブジェクトの名前を指定します。
key 必ず指定します。変更するキーを指定します。
newkey 必ず指定します。引数 key で指定した値と置き換える新しいキーを指定します。


 CompareMode プロパティ は、Dictionary オブジェクトに文字列比較キーの比較モードを設定します。
値の取得も可能です。
 構文
 object.CompareMode[ = compare]

 CompareMode プロパティの構文は、次の指定項目から構成されます。
指定項目 内容
object 必ず指定します。Dictionary オブジェクトの名前を指定します。
compare 省略可能です。StrComp 関数などの関数を使って、比較モードを表す値を指定します。

 引数 compare には、次に示す定数の値を指定できます。
定数 内容
vbUseCompareOption -1 Option Compare ステートメントの設定を使用して比較を行います。
vbBinaryCompare 0 バイナリ モードで比較を行います。
vbTextCompare 1 テキスト モードで比較を行います。
vbDatabaseCompare 2 Microsoft Access の場合のみ有効。データベースに格納されている設定に基づいて比較を行います。

 既にデータが含まれている Dictionary オブジェクトの比較モードを変更しようとすると、エラーが発生します。
 CompareMode プロパティには、StrComp 関数の引数 compare の値と同じ値が使われます。2 より大きな値は、国別情報 (LCID) を使って比較を行うときに使われます。


 Dictionary オブジェクトのメソッド
Add(key, item) 未設定のキー(key)に項目(item)を関連付けます。(キーが存在する場合はエラー)
Exists(key) 指定されたキー(key)が存在するかどうか論理値(True/False)を返します。
Items 連想配列の項目を(0から始まる)配列にして返します。
Keys 連想配列のキーを(0から始まる)配列にして返します。
Remove(key) キー(key)と項目の対を削除します。(指定されたキーが存在しない場合はエラー)
RemoveAll すべてのキーと項目を削除します。


 Exists メソッド は、指定されたキーが Dictionary オブジェクトの中に存在する場合は、真 (True) を返します。
存在しない場合は、偽 (False) を返します。
 構文
 object.Exists(key)

 Exists メソッドの構文は、次の指定項目から構成されます。
指定項目 説明
object 必ず指定します。Dictionary オブジェクトの名前を指定します。
key 必ず指定します。Dictionary オブジェクトの中から検索するキーの値を指定します。


 Keys メソッド は、Dictionary オブジェクトにあるすべてのキーに含まれる配列を返します。
 構文
 object.Keys

 object には、Dictionary オブジェクトの名前を指定します。

 次のコードは、Keys メソッドの使用例です。

Dim a, d, i             '複数の変数を作成します。
Set d = CreateObject("Scripting.Dictionary")
d.Add "a", "Athens"     '複数のキーと項目を追加します。
d.Add "b", "Belgrade"
d.Add "c", "Cairo"
a = d.keys              'キーを取得します。
For i = 0 To d.Count -1 '配列を繰り返します。
    Print a(i)          'キーを印刷します。
Next
...


 Items メソッド は、Dictionary オブジェクトのすべての項目に含まれる配列を返します。
 構文
 object.Items

 object には、Dictionary オブジェクトの名前を指定する必要があります。

 次のコードは、Items メソッドの使用例です。

Dim a, d, i             '複数の変数を作成します。
Set d = CreateObject("Scripting.Dictionary")
d.Add "a", "Athens"     '複数のキーと項目を追加します。
d.Add "b", "Belgrade"
d.Add "c", "Cairo"
a = d.Items             '項目を取得します。
For i = 0 To d.Count -1 '配列を繰り返します。
    Print a(i)          '項目を印刷します。
Next
...


 Add メソッド (Dictionary オブジェクト) は、Dictionary オブジェクトにキーと対の項目を追加します。
 構文
 object.Add key, item

 Add メソッドの構文は、次の指定項目から構成されます。
指定項目 説明
Object 必ず指定します。Dictionary オブジェクトの名前を指定します。
Key 必ず指定します。追加する引数 item と関連付けられた引数 key を指定します。
Item 必ず指定します。追加する引数 key と関連付けられた引数 item を指定します。

 引数 key での指定が既に存在している場合は、エラーとなります。


 RemoveAll メソッド は、Dictionary オブジェクト内のすべてのアイテムを削除します。


 下は、上の 品目マスタと照合 に使う、サンプル・データを生成するためのマクロです。

Option Explicit
Option Base 1

   Dim カウンタ As Integer
   Dim 一桁目 As Integer
   Dim 二桁目 As Integer
   Dim 三桁目 As Integer

Sub サンプルデータ準備()

   Call 品目マスタ捏造
   Call 注文リスト捏造
   ThisWorkbook.Worksheets("スタート").Activate
   
End Sub

Private Sub 品目マスタ捏造()

   Dim 仕入先配列 As Variant
   Dim 仕入先件数 As Integer
   
   ThisWorkbook.Worksheets("仕入先マスタ").Activate
   仕入先配列 = Range("A1").CurrentRegion
   仕入先件数 = UBound(仕入先配列) - 1 '一行目は項目名のため除外
   
   ThisWorkbook.Worksheets("品目マスタ").Activate
   
   カウンタ = 0
   For 一桁目 = 1 To 26
      For 二桁目 = 1 To 26
         For 三桁目 = 1 To 26
            カウンタ = カウンタ + 1
            If カウンタ > 15000 Then Exit For
            Range("A2").Cells(カウンタ, 1).Value _
            = Chr(64 + 一桁目) & Chr(64 + 二桁目) & Chr(64 + 三桁目) '品目コード
            Range("B2").Cells(カウンタ, 1).Value = 仕入先配列(Int(Rnd() * 仕入先件数) + 2, 1)
            Range("C2").Cells(カウンタ, 1).Value = (Int(Rnd() * 1000) + 1) * 10  '単価
            Range("D2").Cells(カウンタ, 1).Value = (Int(Rnd() * 100) + 1) * 10   '重量
         Next 三桁目
      Next 二桁目
   Next 一桁目
End Sub


Private Sub 注文リスト捏造()
   
   ThisWorkbook.Worksheets("注文リスト").Activate
   
   For カウンタ = 1 To 10000
      Range("A2").Cells(カウンタ, 1).Value _
      = Chr(64 + Int(Rnd() * 26) + 1) & Chr(64 + Int(Rnd() * 26) + 1) & Chr(64 + Int(Rnd() * 26) + 1) '品目コード
      Range("B2").Cells(カウンタ, 1).Value = Int(Rnd() * 100) + 1
   Next カウンタ
End Sub

この種類の目次に戻る↑ 索引へ↓ トップページに戻る


Dictionary オブジェクトと Collection オブジェクト

 Dictionary オブジェクトは、Collection オブジェクトと似ていますが、Dictionary オブジェクトには Collection オブジェクトにない、次のような特定の機能が含まれます。
 Collection オブジェクトに対する Dictionary オブジェクトの主な利点は、アイテムの Dictionary オブジェクトは検索が簡単であるということです。
 この利点にもかかわらず、Dictionary オブジェクトを Collection オブジェクトの代わりにすべて使用することはできません。Dictionary オブジェクトより Collection オブジェクトのほうが役に立つ場合もあります。
 たとえば、カスタム オブジェクト モデルを作成する場合、Collection オブジェクトを使用してカスタム コレクションへの参照を保存することができますが、Dictionary オブジェクトではこの操作は行えません。カスタム オブジェクト モデルの作成については、「カスタム クラスとオブジェクト」を参照してください。

 下記にも、Collection オブジェクトと Dictionary オブジェクトを比較したコード例を掲示していただいています。
 Dictionary オブジェクトに関するメモ
http://www.f3.dion.ne.jp/~element/msaccess/AcResTipsWarehouse1.html


 Collection オブジェクト は、1 つのオブジェクトとして参照できる複数の要素の集合です。

 Collection オブジェクトを利用すると、互いに関連付けられた複数の要素を 1 つのオブジェクトとして参照できます。
コレクションの要素、またはメンバはコレクション内に存在することにより関連付けられています。
コレクションのメンバは、同じデータ型を共有する必要はありません。

 Collection オブジェクトは、他のオブジェクトと同じ方法で作成できます。たとえば、次のように宣言します。
Dim X As New Collection
 作成した Collection オブジェクトにメンバを追加するときには Add メソッドを使い、メンバを削除するときには Remove メソッドを使います。
また、Collection オブジェクトから特定のメンバを取得するときには Item メソッドを使い、Collection オブジェクトに含まれるすべてのメンバを取得するときには For Each ... Next ステートメントを使います。

 次の例は、Collection オブジェクト (MyClasses) を作成した後、このコレクションにオブジェクトを追加するためのダイアログ ボックスを表示します。
このプログラムを実行するには、まず、[挿入] - [クラス モジュール] をクリックしてから、各インスタンスの名前を格納するパブリック変数 InstanceName を Class1 のモジュール レベルで宣言します (「Public InstanceName」と入力)。
モジュール名は、既定値の Class1 のまま変えないでください。
下のコードをコピーし、別のモジュールの宣言セクションにコードを貼り付け、他のプロシージャの ClassNamer ステートメントで起動します。
この例では、ホスト アプリケーションがクラスをサポートする場合のみ実行できます。

Sub ClassNamer()
    Dim MyClasses As New Collection    ' Collection オブジェクトを作成します。
    Dim Num                            ' 個々のインスタンスを区別するためのカウンタを宣言します。
    Dim Msg As String                  ' メッセージ用の文字列を格納する変数を宣言します。
    Dim TheName, MyObject, NameList    ' 情報を格納するバリアント型の変数を宣言します。

    Do
        Dim Inst As New Class1         ' Class1 の新しいインスタンスを作成します。
        Num = Num + 1                  ' 変数 Num を加算した後、インスタンスの名前を取得します。
        Msg = "このオブジェクトの名前を入力してください。" & Chr(13) _
         & "コレクション内のオブジェクトの名前を確認するには、キャンセル ボタンを押してください。"
        TheName = InputBox(Msg, "コレクション アイテムの名前付け")
        Inst.InstanceName = TheName    ' オブジェクトのインスタンスに名前を代入します。

        ' ユーザーが名前を入力した場合は、オブジェクトをコレクションに追加します。
        If Inst.InstanceName <> "" Then
            ' 名前を付けたオブジェクトをコレクションに追加します。
            MyClasses.Add item := Inst, key := CStr(Num)
        End If

        ' 次の参照の準備のため、現在の参照内容をクリアします。
        Set Inst = Nothing
    Loop Until TheName = ""

    For Each MyObject In MyClasses     ' インスタンスの名前の一覧を作成します。
        NameList = NameList & MyObject.InstanceName & Chr(13)
    Next MyObject

    ' メッセージ ボックスにインスタンスの名前の一覧を表示します。
    MsgBox NameList, , "MyClasses コレクション内のインスタンスの名前"

    For Num = 1 To MyClasses.Count     ' コレクションからオブジェクトの名前を削除します。
        MyClasses.Remove 1             ' コレクションは自動的にインデックスが付け直されるので、
                                       ' ループを繰り返すごとに先頭のメンバを削除します。
    Next
End Sub

この種類の目次に戻る↑ 索引へ↓ トップページに戻る


ホームページのトップに戻る