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

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

基本操作
連想配列を使って検索を高速化する
 ・ホームページから写真リンクを取得
 ・英文テキストから英単語帳を作成
 ・シーザー暗号(換字暗号)
 ・文字の出現頻度を数える
 ・品目マスタと照合
 ・キーとデータ(項目・値など)を対応表示する
 ・フォルダ内のファイル名の接頭辞で計数
Dictionary オブジェクトと Collection オブジェクト
 ・九九の問題を生成(Collection使用)

索引


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

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

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

 上のサイトで教えていただいた方法を、マクロに応用したら、処理速度が10倍以上、速くなりました。目からうろこ、大感激です。
 Dictionay オブジェクトを使うと、キーに対するデータを瞬時に取り出すことができ、キーの存在チェック も、簡単にできます。

 Dictionay オブジェクト は、Item番号を付けて、データ(要素、Items)とキー(Keys)をセットで、格納します。
 1.キーは、整数だけでなく、文字列などを指定できます。
 2.キーは、重複させることはできません。(重複しないことが保証されていることが役に立つのです。)
 3.キーに対応したデータ(項目・値など)を、対で格納します。
 4.キーの存在を簡単にチェックできます。
 5.キーを指定して、キーに対応したデータ(項目・値など)を簡単に取り出すことができます。
 Item 1〜の番号は、キーを追加するときに、自動的に設定されます。

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

 For〜Each文を使ってDictionaryの内容を出力する
https://tonari-it.com/excel-vba-dictionary-keys-items/
https://www.excel-wing.com/study/jitumu/970

 実行時エラー '451':
Property Let プロシージャが定義されておらず、Property Get プロシージャからオブジェクトが返されませんでした。
https://vba-create.jp/vba-dictionary-error-451-property-let/

 一旦KeysをVariant変数に格納することが重要です。★
http://blog.livedoor.jp/springjoe2/archives/52121849.html

https://qiita.com/nkmrtkhd/items/b451b66249dd737396bd


ホームページから写真リンクを取得

 複数ページから取得した写真URLの重複を排除するために使っています。
この種類の目次に戻る↑ 索引へ↓ トップページに戻る

英文テキストから英単語帳を作成

 英語学習に役立つことを期待して、英文テキストや ePub から英単語帳を作成する Excel マクロを作りました。
 読もうと思っているテキストには、どの程度の語彙力が必要かが 10秒程度で具体的に分かります。

英和辞書入手先: ブラウザで使えるWeb便利ツール - 無料 英和辞書データ ダウンロード
英文入手先の例: English e-Reader (検索ページ)

 マクロの使い方:
1.英単語帳作成用の専用フォルダを作成します。(例:D:\epub\★英単語帳作成\)
2.このフォルダに、@このExcelマクロ、A辞書ファイル、B単語帳作成対象の英文ファイル、を登録します。
英文ファイルには、映画の字幕データ(拡張子.srt)も対象として使えます。
英文 ePub から単語帳を作成する場合は、ePub を zip解凍してできる html/xhtml ファイルを含むフォルダに、このマクロと辞書を登録(移動)して下さい。
3.このマクロを実行すると、英文ファイル名のシートに単語帳が作成されます。
4.単語帳に出力したくない単語は、「既知単語」シートに、英文だけ追記すると、除外できます。
「既知単語」シートは、このマクロで並び替えられて日本語部分が追記されます。
5.「日本語」シートで、!名前? をフィルタ抽出すると、辞書に存在しない登場人物?名を出力できます。

このマクロをダウンロードできます→EnglishVocabularyNoteVBA12.xls ←2024/05/15更新

aフロー
Option Explicit

Public 開始日時 As Variant
Public 終了日時 As Variant
Public 既知単語索引 As Object              'Scripting.Dictionary オブジェクト

Sub 英単語帳作成()

   開始日時 = Now                                      ' 開始時刻を変数に格納
   
   Set 既知単語索引 = CreateObject("Scripting.Dictionary")  '★連想配列の定義
   Call 既知単語登録
   
   Call 英文ファイルから単語リスト作成
   Set 既知単語索引 = Nothing                               '★連想配列を削除
'Stop
   Call 英和辞書読込
   
End Sub

b既知登録
Option Explicit

Sub 既知単語登録()
   Dim 最終行 As Integer
   Dim 処理行 As Integer
   Dim 既知単語 As String
   
'   最終行の検出方法:教えていただいたサイト
'   https://www.niji.or.jp/home/toru/notes/8.html
   With Worksheets("既知単語").UsedRange
      最終行 = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
   End With
   
   For 処理行 = 1 To 最終行
      既知単語 = Trim(Worksheets("既知単語").Range("A1").Cells(処理行, 1).Value)
      '既知単語を連想配列「既知単語索引」に格納
      If 既知単語 <> "" Then
         If 既知単語索引.Exists(既知単語) = False Then
            既知単語索引(既知単語) = "既知"
         End If
      End If
   Next 処理行
End Sub
この種類の目次に戻る↑ 索引へ↓ トップページに戻る

c英文読込
Option Explicit

'04 2022/05/10:$500対応。セルで「通貨」や「論理値」として誤認されないように
'05 2022/05/10:日本語半角 ASCII にない、引用符やアポストロフィを除去
               '(VBAエディタは UNICODE文字を扱えない)
'06 2022/05/12:アポストロフィを除外して文字数フィルタ

   Dim 入力文字列 As String
   Dim 出力単語文字数 As Integer
   Dim 単語索引 As Object           'Scripting.Dictionary オブジェクト
   Dim デバッグ As String

Sub 英文ファイルから単語リスト作成()
'英文テキスト・ファイルを読み込む。もしくは、
'英文 ePub を解凍してできる html(UTF-8) を読み込む

   Dim 入力ファイル名 As String
   Dim 入力行 As String
   Dim ファイルシステムオブジェクト As Object        ' FileSystemObject
   Dim 入力ADODBストリーム  As Object                ' ADODB.Stream
   Dim 現在のパス As String
   Dim フォルダ As Object
   Dim ファイル As Object
   Dim フォルダパス As String
   Dim 単語配列()
   Dim 頻度配列()
   Dim 追加シート名初期 As String
   Dim 追加シート名 As String
   Dim 重複 As Integer
   Dim シート As Worksheet
   Dim シート数 As Integer
   Dim 本文 As String
   Dim 本文配列() As String
   Dim 行 As Integer


   追加シート名初期 = "英語単語帳"
   デバッグ = ""

   現在のパス = ThisWorkbook.Path
   出力単語文字数 = ThisWorkbook.Worksheets("スタート").Range("B11").Value
   入力ファイル名 = ThisWorkbook.Worksheets("スタート").Range("B8").Value

   Set 単語索引 = CreateObject("Scripting.Dictionary")  '★連想配列の定義
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   
   If 入力ファイル名 <> "" Then
      '********************************
      入力ファイル名 = 現在のパス & "/" & 入力ファイル名
      追加シート名初期 = Left(ファイルシステムオブジェクト.GetBaseName(入力ファイル名), 15)

      'ファイルのオープン。
'      UTF8 テキスト・ファイルとして読むように変更した
      With CreateObject("ADODB.Stream")
         .Charset = "UTF-8"
         .Open
         .LoadFromFile 入力ファイル名
         Do Until .EOS
            本文 = .ReadText(-2)                                      '1行ずつ読み込む
            'LF で改行したファイルの場合、すべて1行目に読み込まれてしまいます。
            ' vbLf(LF)で文字列を分割し、本文配列に格納する
            本文配列 = Split(本文, vbLf)
            ' 本文配列の要素数でループ処理する。
            For 行 = 0 To UBound(本文配列)
               入力文字列 = 本文配列(行)
               'vba “ (u201C) ”(u201D)を半角の " にしたい
               入力文字列 = StrConv(入力文字列, vbNarrow)                      '全角文字を半角に変換
               入力文字列 = Replace(入力文字列, vbTab, "")                     'タブ削除
               入力文字列 = Replace(入力文字列, "_", "")                       '_ 削除
               If Left(入力文字列, 1) = "'" Or Left(入力文字列, 1) = """" Then '行頭の '、" 削除
                  入力文字列 = Right(入力文字列, Len(入力文字列) - 1)
               End If
               If Len(入力文字列) > 0 Then
                  Call 単語登録   '★★★★★
               End If
            ' 最終行まで繰り返す
            Next 行
         Loop
         .Close
      End With

   Else
      Set フォルダ = ファイルシステムオブジェクト.GetFolder(現在のパス)
      '★上で指定したフォルダ内の、全てのファイルを対象に検索
      For Each ファイル In フォルダ.Files

         入力ファイル名 = ファイル.Path
         
         If ファイルシステムオブジェクト.GetExtensionName(ファイル.Path) = "html" _
         Or ファイルシステムオブジェクト.GetExtensionName(ファイル.Path) = "xhtml" Then
   '         ファイルの拡張子を返します。ピリオドは含みません。
            本文 = ""
            ' 指定ファイルをOPEN(入力モード)
            Set 入力ADODBストリーム = CreateObject("ADODB.Stream")       'ADODB.Stream生成
            
   '         https://qiita.com/5zm/items/a8ba71d47d161b52c823
            'テキスト Stream オブジェクトの行区切りに使われている文字
            '定数  値 説明
            'adCR  13 改行復帰を示します。
            'adCRLF   -1 既定値です。改行復帰行送りを示します。
            'adLF  10 行送りを示します。
            
            With 入力ADODBストリーム
               .Open               'Streamのオープン
               .Type = 2           'adTypeText Textモード
               .Charset = "UTF-8"  '文字コード(Shift_JIS, Unicodeなど)
               .LineSeparator = 10 'adCRLF   -1 既定値、10 = LF 、adCR  13、これが違うと行単位にできない
               .LoadFromFile (入力ファイル名)
            End With
         
            '*************データの読み込み***********
            Do Until 入力ADODBストリーム.EOS
                 
               ' レコードの読み込み
               入力行 = 入力ADODBストリーム.ReadText(-2) '-2 adReadLine
   '            Stop
               入力行 = Replace(入力行, vbTab, "")       'タブ削除
               入力行 = Replace(入力行, "_", "")         '_削除
               入力行 = Trim(入力行)
               
               If InStr(入力行, "<body") > 0 Then
                  本文 = "本文"
               ElseIf InStr(入力行, "<title") > 0 And 追加シート名初期 = "英語単語帳" Then
                  入力行 = 正規表現で置換(入力行, "<(.*?)>", "")
                  If Len(入力行) > 0 Then
                     追加シート名初期 = Left(入力行, 15)
                     追加シート名初期 = Replace(追加シート名初期, ":", "") 'シート名として使えない文字を削除
                  End If
               End If

               入力行 = Replace(入力行, "<br/>", " ") '改行が欠落することを防ぐ
               入力行 = 正規表現で置換(入力行, "<(.*?)>", "")
               入力文字列 = StrConv(入力行, vbNarrow)   ' 全角文字を半角に変換
               入力文字列 = Replace(入力文字列, "&#8211;", "-")                '文字コード変換
               入力文字列 = Replace(入力文字列, "&#8212;", "-")                '文字コード変換
               入力文字列 = Replace(入力文字列, "&nbsp;", " ")                 '文字コード変換
'               Stop
               入力文字列 = Trim(入力文字列)
               If Left(入力文字列, 1) = "'" Or Left(入力文字列, 1) = """" Then           '行頭の ' と" を削除
                  入力文字列 = Right(入力文字列, Len(入力文字列) - 1)
               End If
               If Len(入力文字列) > 0 And 本文 <> "" Then
'               Stop
'                  If InStr(入力文字列, "they'll") > 0 Then Stop
   
                  Call 単語登録
                  
               End If
               ' 最終行まで繰り返す
            Loop
            ' 指定ファイルをCLOSE
            入力ADODBストリーム.Close
            Set 入力ADODBストリーム = Nothing
            
         End If
      Next '★ファイル
   End If
   
   単語配列 = 単語索引.keys
   頻度配列 = 単語索引.Items

   '上で取得した配列は 1次元のため、行方向の 2次元配列に変換する。
   単語配列 = WorksheetFunction.Transpose(単語配列)
   頻度配列 = WorksheetFunction.Transpose(頻度配列)

'   追加シート名初期 = "英語単語帳"
   追加シート名 = 追加シート名初期

   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(単語索引.Count, 1) = 単語配列
   Range("B2").Resize(単語索引.Count, 1) = 頻度配列

   Range("A1").CurrentRegion.Sort _
   Key1:=Range("A1"), Order1:=xlAscending, _
   Header:=xlYes

   'クローズ
   Set ファイルシステムオブジェクト = Nothing
   Set 単語索引 = Nothing '★連想配列を削除
   
End Sub


Private Sub 単語登録()
   Dim 行文字数 As Integer
   Dim 検索文字目 As Integer
   Dim 単語文字数 As Integer
   Dim 単語開始文字目 As Integer
   Dim 英単語 As String
   
   行文字数 = Len(入力文字列)
   単語文字数 = 0
   
   For 検索文字目 = 1 To 行文字数    '単語の区切りを見つける
      If Mid(入力文字列, 検索文字目, 1) = " " _
      Or Mid(入力文字列, 検索文字目, 1) = "." _
      Or Mid(入力文字列, 検索文字目, 1) = "," _
      Or Mid(入力文字列, 検索文字目, 1) = "?" _
      Or Mid(入力文字列, 検索文字目, 1) = "!" _
      Or Mid(入力文字列, 検索文字目, 1) = ":" _
      Or Mid(入力文字列, 検索文字目, 1) = ";" _
      Or Mid(入力文字列, 検索文字目, 1) = "/" _
      Or Mid(入力文字列, 検索文字目, 1) = "-" _
      Or Mid(入力文字列, 検索文字目, 1) = "*" _
      Or Mid(入力文字列, 検索文字目, 1) = "(" _
      Or Mid(入力文字列, 検索文字目, 1) = ")" _
      Or Mid(入力文字列, 検索文字目, 1) = "[" _
      Or Mid(入力文字列, 検索文字目, 1) = "]" _
      Or Mid(入力文字列, 検索文字目, 1) = """" Then
      
'      Or Mid(入力文字列, 検索文字目, 1) = "'"  'アポストロフィ付き単語を含めるため
         
         If 単語文字数 >= 出力単語文字数 Then
            英単語 = Trim(Mid(入力文字列, 単語開始文字目, 単語文字数))
            'Stop
            If 英単語 <> "" And IsNumeric(英単語) = False _
            And IsNumeric(Left(英単語, 1)) = False Then    '数値を除外
'               英単語 = LCase(英単語)                     '登録段階では小文字に統一しない
               
               If Right(英単語, 2) = "'s" Then
                  英単語 = Left(英単語, Len(英単語) - 2)   'アポストロフィ s を除外
               ElseIf Right(英単語, 1) = "'" Then
                  英単語 = Left(英単語, Len(英単語) - 1)   'アポストロフィを除外
               End If
               
               If Len(英単語) >= 出力単語文字数 Then  'アポストロフィを除外して文字数を再チェック

                  If 既知単語索引.Exists(英単語) = False _
                  And 既知単語索引.Exists(LCase(英単語)) = False Then '既知単語登録は大文字の場合もある
                  '既知単語でない場合。既知単語との比較では小文字にする
   '                  Stop
                     If Left(英単語, 1) = "$" Then            '$500 を文字列に
                        英単語 = "'" & 英単語
                     ElseIf LCase(英単語) = "false" Or LCase(英単語) = "true" Then
                        英単語 = "'" & 英単語                 '論理値でなく単純文字列にする
                     End If
                     '英単語を連想配列「単語索引」に格納する
                       If 英単語 = "incas" Then Stop
   '                    If InStr(英単語, "resume") > 0 Then Stop
                     If 単語索引.Exists(英単語) = True Then
                        単語索引(英単語) = 単語索引(英単語) + 1
                     Else
                        単語索引(英単語) = 1
                     End If
                  End If
               End If
            End If
         End If
         単語文字数 = 0
      Else
         If 単語文字数 = 0 Then
            単語開始文字目 = 検索文字目

         End If
         単語文字数 = 単語文字数 + 1
      End If
      If Mid(入力文字列, 検索文字目, 2) = " '" Then
         検索文字目 = 検索文字目 + 1
      End If
   Next 検索文字目
               
End Sub



'正規表現で置換
'http://codezine.jp/article/detail/1655?p=3
'[引数]
'検索文字列
'正規表現パターン
'置換文字列 正規表現パターンに ()を使って保存した部分は、置換文字列 $n で呼び出せます。
'[返り値]
'検索文字列内に正規表現パターンが見つかった場合:置換文字列に置き換えた結果を返す
'検索文字列内に正規表現パターンが見つからなかった場合
':検索文字列に変更を加えずそのまま返す

Function 正規表現で置換(検索文字列 As String, 正規表現パターン As String, 置換文字列 As String) As String
    Dim 正規表現 As New RegExp            ' 正規表現を作成します。
    正規表現.Pattern = 正規表現パターン  ' パターンを設定します。
    正規表現.Global = True               ' 一致するもの全てを対象とするように設定します。
    正規表現で置換 = 正規表現.Replace(検索文字列, 置換文字列)   ' 置換します。
End Function
この種類の目次に戻る↑ 索引へ↓ トップページに戻る

d辞書読込
Option Explicit

'03 2022/05/09:既知単語シートに日本語追記
'04 2022/05/09:活用の除外追加。英和辞書のデータ考慮
'abettor, abetter
'abridgment, abridgement
'absinthe, absinth
'accouter, accoutre
'06 2022/05/12:活用を除外しても、英単語は元の大文字を残す
'07 2022/05/14:活用検索対象の文字数を制限

   Dim 単語索引 As Object        'Scripting.Dictionary オブジェクト
   Dim 英単語 As String
   Dim 英単語小文字 As String
   Dim 接頭辞 As String
   Dim 接頭辞日本 As String
   Dim 日本語 As String
   Dim 処理行 As Integer
   
Sub 英和辞書読込()

   Dim 入力ファイル名 As String
   Dim 入力行 As String
   Dim 入力ADODBストリーム  As Object                ' ADODB.Stream
   Dim 現在のパス As String
   Dim フォルダ As Object
   Dim ファイル As Object
   Dim フォルダパス As String

'   Dim 活用 As String


   現在のパス = ThisWorkbook.Path

   Set 単語索引 = CreateObject("Scripting.Dictionary")  '★連想配列の定義
'   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")

   'ejdict-hand-utf820201114.txt(UTF-8) を読み込む
   入力ファイル名 = ThisWorkbook.Worksheets("スタート").Range("B12").Value
   入力ファイル名 = 現在のパス & "/" & 入力ファイル名
'   Stop
   ' 指定ファイルをOPEN(入力モード)

   Set 入力ADODBストリーム = CreateObject("ADODB.Stream")       'ADODB.Stream生成
   
'   https://qiita.com/5zm/items/a8ba71d47d161b52c823
   'テキスト Stream オブジェクトの行区切りに使われている文字
   '定数  値 説明
   'adCR  13 改行復帰を示します。
   'adCRLF   -1 既定値です。改行復帰行送りを示します。
   'adLF  10 行送りを示します。
   
   With 入力ADODBストリーム
      .Open               'Streamのオープン
      .Type = 2           'adTypeText Textモード
      .Charset = "UTF-8"  '文字コード(Shift_JIS, Unicodeなど)
      .LineSeparator = 10 'adCRLF   -1 既定値、10 = LF 、adCR  13、これが違うと行単位にできない
      .LoadFromFile (入力ファイル名)
   End With

   '*************データの読み込み***********
   Do Until 入力ADODBストリーム.EOS
        
      ' レコードの読み込み
      入力行 = 入力ADODBストリーム.ReadText(-2) '-2 adReadLine
'            Stop
'      入力行 = Replace(入力行, vbTab, "")           'タブ削除
      If Len(入力行) > 0 Then

         英単語 = Left(入力行, InStr(入力行, vbTab) - 1)
         日本語 = Right(入力行, Len(入力行) - InStr(入力行, vbTab))
'         Stop
         If InStr(英単語, ", ") > 0 Then
         '複数のキーがある場合 間が「, 」
            If 単語索引.Exists(Left(英単語, InStr(英単語, ", ") - 1)) = False Then
               単語索引(Left(英単語, InStr(英単語, ", ") - 1)) = 日本語
            End If
            
            If 単語索引.Exists(Right(英単語, Len(英単語) - InStr(英単語, ", ") - 1)) = False Then
'               Stop
               単語索引(Right(英単語, Len(英単語) - InStr(英単語, ", ") - 1)) = 日本語
            End If
         ElseIf InStr(英単語, ",") > 0 Then
         '複数のキーがある場合 間が「,」だけ
            If 単語索引.Exists(Left(英単語, InStr(英単語, ",") - 1)) = False Then
               単語索引(Left(英単語, InStr(英単語, ",") - 1)) = 日本語
            End If
            
            If 単語索引.Exists(Right(英単語, Len(英単語) - InStr(英単語, ","))) = False Then
'               Stop
               単語索引(Right(英単語, Len(英単語) - InStr(英単語, ","))) = 日本語
            End If
         Else
            If 単語索引.Exists(英単語) = False Then
               単語索引(英単語) = 日本語
            End If
         End If

      End If
      ' 最終行まで繰り返す
   Loop

   ' 指定ファイルをCLOSE
   入力ADODBストリーム.Close
   Set 入力ADODBストリーム = Nothing
   '辞書データの読込はここまでで終わり
   
   '***************************************************:
   Call 既知単語に和訳追記
   
   '***************************************************:
   '単語帳に和訳追記
   Dim 最終行 As Integer

'   教えていただいたサイト
'   http://www.niji.or.jp/home/toru/notes/8.html
   With ActiveSheet.UsedRange
      最終行 = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
   End With

   For 処理行 = 2 To 最終行
      接頭辞 = ""
      接頭辞日本 = ""
      英単語 = Range("A1").Cells(処理行, 1).Value
'      If 英単語 = "Incas" Then Stop
      日本語 = 単語索引.Item(英単語)
      '日本語が有れば、このループの最後で C1 セルに書く
      '日本語が無ければ、以下の活用で検索し直して、日本語が見つかるまで試す
      
      If 日本語 = "" Then '辞書にないとき、小文字で検索
         英単語小文字 = LCase(英単語)
         日本語 = 単語索引.Item(英単語小文字)
      End If
      
      Call 活用検索
      
      If 日本語 = "" Then '辞書にないとき、接頭辞を除く
         If Left(英単語小文字, 2) = "in" Then
            接頭辞 = "in+"
            接頭辞日本 = "「否定/中へ/上に」+" & vbLf
            日本語 = 単語索引.Item(Right(英単語小文字, Len(英単語小文字) - 2))
            If 日本語 <> "" Then '辞書に有った
               Range("A1").Cells(処理行, 1).Value = 接頭辞 & Right(英単語, Len(英単語) - 2)
            Else
               英単語小文字 = Right(英単語小文字, Len(英単語小文字) - 2)
               英単語 = Right(英単語, Len(英単語) - 2)

               Call 活用検索
            End If
         ElseIf Left(英単語小文字, 2) = "un" Then
            'un を in にして検索してみる
            日本語 = 単語索引.Item("in" & Right(英単語小文字, Len(英単語小文字) - 2))
            If 日本語 <> "" Then '辞書に有った
               Range("A1").Cells(処理行, 1).Value = 英単語 & "(in" & Right(英単語小文字, Len(英単語小文字) - 2)
            Else
               接頭辞 = "un+"
               接頭辞日本 = "「否定」+" & vbLf
               日本語 = 単語索引.Item(Right(英単語小文字, Len(英単語小文字) - 2))
               If 日本語 <> "" Then '辞書に有った
                  Range("A1").Cells(処理行, 1).Value = 接頭辞 & Right(英単語, Len(英単語) - 2)
               Else
                  英単語小文字 = Right(英単語小文字, Len(英単語小文字) - 2)
                  英単語 = Right(英単語, Len(英単語) - 2)
                  
                  Call 活用検索
               End If
            End If
         End If
      End If
      
      If 接頭辞 <> "" And 日本語 <> "" Then
         Select Case 接頭辞
            Case "un+"
               接頭辞日本 = "「否定」+" & vbLf
               日本語 = 接頭辞日本 & 日本語
            Case Else
               接頭辞日本 = "「否定/中へ/上に」+" & vbLf
               日本語 = 接頭辞日本 & 日本語
         End Select
      End If
      
      If Left(日本語, 1) = "=" Then
         日本語 = "'" & 日本語 'セルの計算式指定エラーにならないように
      End If
      'セル内改行に修正
      Range("C1").Cells(処理行, 1).Value = Replace(日本語, " / ", vbLf)
   Next 処理行

   'クローズ
'   Set ファイルシステムオブジェクト = Nothing
   Set 単語索引 = Nothing '★連想配列を削除
   
   終了日時 = Now
   MsgBox "処理を終了しました。" & vbNewLine & "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub


Private Sub 活用検索()

'      If 英単語 = "incurred" Then Stop
               
      If 日本語 = "" Then                 '辞書にないとき、活用を考慮する
         If Len(英単語小文字) > 3 Then '語根が3以上の場合に活用を考える
            If Right(英単語小文字, 1) = "s" Then
               日本語 = 単語索引.Item(Left(英単語小文字, Len(英単語小文字) - 1))
               If 日本語 <> "" Then          '辞書に有った
                  Range("A1").Cells(処理行, 1).Value = 接頭辞 & Left(英単語, Len(英単語) - 1) & "+s"
                  '英単語が異字体なのに小文字で統一すると重複して不信に感じるため
                  'Range("A1") に書き出すのは「英単語小文字」ではなく「英単語」の方を使う
               End If
            ElseIf Right(英単語小文字, 1) = "d" Then
               日本語 = 単語索引.Item(Left(英単語小文字, Len(英単語小文字) - 1))
               If 日本語 <> "" Then          '辞書に有った
                  Range("A1").Cells(処理行, 1).Value = 接頭辞 & Left(英単語, Len(英単語) - 1) & "+d"
               End If
            End If
         End If
      End If
      
      If 日本語 = "" Then                 '辞書にないとき、活用を考慮する
         If Len(英単語小文字) > 4 Then '語根が4以上の場合に活用を考える
            If Right(英単語小文字, 2) = "ed" Then
               日本語 = 単語索引.Item(Left(英単語小文字, Len(英単語小文字) - 2))
               If 日本語 <> "" Then          '辞書に有った
                  Range("A1").Cells(処理行, 1).Value = 接頭辞 & Left(英単語, Len(英単語) - 2) & "+ed"
               Else
                  If Right(英単語小文字, 3) = "ied" Then
                     'carried、buried
                     日本語 = 単語索引.Item(Left(英単語小文字, Len(英単語小文字) - 3) & "y")
                     If 日本語 <> "" Then       '辞書に有った
                        Range("A1").Cells(処理行, 1).Value _
                        = 接頭辞 & Left(英単語, Len(英単語) - 3) & "y(" & 英単語 & ")"
                     End If
                  ElseIf Len(英単語小文字) > 4 Then
                     If Mid(英単語小文字, Len(英単語小文字) - 3, 1) = Mid(英単語小文字, Len(英単語小文字) - 2, 1) Then
                        'stepped incurred
                        日本語 = 単語索引.Item(Left(英単語小文字, Len(英単語小文字) - 3))
                        If 日本語 <> "" Then    '辞書に有った
                           Range("A1").Cells(処理行, 1).Value _
                           = 接頭辞 & Left(英単語, Len(英単語) - 3) & "+" & Right(英単語, 3)
                        End If
                     End If
                  End If
               End If
               
            ElseIf Right(英単語小文字, 2) = "er" Then
               日本語 = 単語索引.Item(Left(英単語小文字, Len(英単語小文字) - 1))
               If 日本語 <> "" Then          '辞書に有った safer
                  Range("A1").Cells(処理行, 1).Value = 接頭辞 & Left(英単語, Len(英単語) - 1) & "+r"
               Else
                  日本語 = 単語索引.Item(Left(英単語小文字, Len(英単語小文字) - 2))
                  If 日本語 <> "" Then       '辞書に有った
                     Range("A1").Cells(処理行, 1).Value = 接頭辞 & Left(英単語, Len(英単語) - 2) & "+er"
                  Else
                     日本語 = 単語索引.Item(Left(英単語小文字, Len(英単語小文字) - 3) & "y") 'earlier
                     If 日本語 <> "" Then    '辞書に有った
                        Range("A1").Cells(処理行, 1).Value _
                        = Left(英単語, Len(英単語) - 3) & "y(" & 英単語 & ")"
                     Else
                        日本語 = 単語索引.Item(Left(英単語小文字, Len(英単語小文字) - 3))  'hotter
                        If 日本語 <> "" Then '辞書に有った
                           Range("A1").Cells(処理行, 1).Value _
                           = Left(英単語, Len(英単語) - 3) & "+" & Right(英単語, 3)
                        End If
                     End If
                  End If
               End If
               
            ElseIf Right(英単語小文字, 2) = "es" Then
               日本語 = 単語索引.Item(Left(英単語小文字, Len(英単語小文字) - 2))
               If 日本語 <> "" Then          '辞書に有った
                  Range("A1").Cells(処理行, 1).Value = 接頭辞 & Left(英単語, Len(英単語) - 2) & "+es"
               Else
                  If Right(英単語小文字, 3) = "ies" Then
                  'companies   Charles
                  日本語 = 単語索引.Item(Left(英単語小文字, Len(英単語小文字) - 3) & "y")
                     If 日本語 <> "" Then       '辞書に有った
                        Range("A1").Cells(処理行, 1).Value _
                        = Left(英単語, Len(英単語) - 3) & "y(" & 英単語 & ")"
                     End If
                  End If
               End If
               
            ElseIf Right(英単語小文字, 2) = "ly" Then
               日本語 = 単語索引.Item(Left(英単語小文字, Len(英単語小文字) - 2))
               If 日本語 <> "" Then          '辞書に有った
                  Range("A1").Cells(処理行, 1).Value = 接頭辞 & Left(英単語, Len(英単語) - 2) & "+ly"
               Else
                  日本語 = 単語索引.Item(Left(英単語小文字, Len(英単語小文字) - 1) & "e")
                  If 日本語 <> "" Then          '辞書に有った
                     Range("A1").Cells(処理行, 1).Value _
                     = 接頭辞 & Left(英単語, Len(英単語) - 1) & "e(" & 英単語 & ")"
                  End If
               End If
            ElseIf Right(英単語小文字, 3) = "est" Then
               日本語 = 単語索引.Item(Left(英単語小文字, Len(英単語小文字) - 2))
               If 日本語 <> "" Then          '辞書に有った
                  Range("A1").Cells(処理行, 1).Value = 接頭辞 & Left(英単語, Len(英単語) - 2) & "+st"
               Else
                  日本語 = 単語索引.Item(Left(英単語小文字, Len(英単語小文字) - 3))
                  If 日本語 <> "" Then       '辞書に有った
                     Range("A1").Cells(処理行, 1).Value = 接頭辞 & Left(英単語, Len(英単語) - 3) & "+est"
                  Else
                     日本語 = 単語索引.Item(Left(英単語小文字, Len(英単語小文字) - 4))
                     If 日本語 <> "" Then    '辞書に有った
                        Range("A1").Cells(処理行, 1).Value _
                        = 接頭辞 & Left(英単語, Len(英単語) - 4) & "+" & Right(英単語小文字, 4)
                     End If
                  End If
               End If
               
            ElseIf Right(英単語小文字, 4) = "ness" Then
               日本語 = 単語索引.Item(Left(英単語小文字, Len(英単語小文字) - 4))
               If 日本語 <> "" Then          '辞書に有った
                  Range("A1").Cells(処理行, 1).Value = 接頭辞 & Left(英単語, Len(英単語) - 4) & "+ness"
               End If
               
            ElseIf Right(英単語小文字, 4) = "less" Then
               日本語 = 単語索引.Item(Left(英単語小文字, Len(英単語小文字) - 4))
               If 日本語 <> "" Then          '辞書に有った
                  Range("A1").Cells(処理行, 1).Value = 接頭辞 & Left(英単語, Len(英単語) - 4) & "+less"
               End If
   
            ElseIf Right(英単語小文字, 3) = "men" Then
               日本語 = 単語索引.Item(Left(英単語小文字, Len(英単語小文字) - 3) & "man")
               If 日本語 <> "" Then          '辞書に有った
                  Range("A1").Cells(処理行, 1).Value = 接頭辞 & 英単語 & "(" & Left(英単語, Len(英単語) - 3) & "man)"
               End If
               
            ElseIf Right(英単語小文字, 3) = "ing" Then
               日本語 = 単語索引.Item(Left(英単語小文字, Len(英単語小文字) - 3) & "e")
               If 日本語 <> "" Then          '辞書に有った  changing
                  Range("A1").Cells(処理行, 1).Value = 接頭辞 & Left(英単語, Len(英単語) - 3) & "e(" & 英単語 & ")"
               Else
                  日本語 = 単語索引.Item(Left(英単語小文字, Len(英単語小文字) - 3))
                  If 日本語 <> "" Then       '辞書に有った
                     Range("A1").Cells(処理行, 1).Value = 接頭辞 & Left(英単語, Len(英単語) - 3) & "+ing"
                  ElseIf Len(英単語小文字) > 4 Then
                     If Mid(英単語小文字, Len(英単語小文字) - 4, 1) = Mid(英単語小文字, Len(英単語小文字) - 3, 1) Then
         '               controlling"mming""nning""pping""rring"
                        日本語 = 単語索引.Item(Left(英単語小文字, Len(英単語小文字) - 4))
                        If 日本語 <> "" Then    '辞書に有った
                           Range("A1").Cells(処理行, 1).Value _
                           = 接頭辞 & Left(英単語, Len(英単語) - 4) & "+" & Right(英単語小文字, 4)
                        End If
                     End If
                  End If
               End If
            End If
         End If
      End If
End Sub


Private Sub 既知単語に和訳追記()
   Dim 最終行 As Integer
   Dim 処理行 As Integer
   Dim 日本語 As String
   
   '既知単語をソート
   Worksheets("既知単語").UsedRange.Sort _
      Key1:=Worksheets("既知単語").Range("A1"), Order1:=xlAscending, _
      Header:=xlNo

'   最終行の検出方法:教えていただいたサイト
'   https://www.niji.or.jp/home/toru/notes/8.html
   With Worksheets("既知単語").UsedRange
      最終行 = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
   End With
   
   For 処理行 = 1 To 最終行
      If Worksheets("既知単語").Range("B1").Cells(処理行, 1).Value = "" Then
         日本語 = 単語索引.Item(Worksheets("既知単語").Range("A1").Cells(処理行, 1).Value)
         If Left(日本語, 1) = "=" Then
            日本語 = "'" & 日本語 'セルの計算式指定エラーにならないように
         End If
         'セル内改行に修正して登録
         Worksheets("既知単語").Range("B1").Cells(処理行, 1).Value = Replace(日本語, " / ", vbLf)
      End If
   Next 処理行
End Sub

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

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

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


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

品目マスタと照合


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

このマクロをダウンロードできます→DictionaryVBA02.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 が使えます。

私は、この参照設定は使っていません。例えば、
 Dim 写真URL索引 As Object 'Scripting.Dictionary オブジェクト
 '★写真URL索引を作成★
 Set 写真URL索引 = CreateObject("Scripting.Dictionary") '★連想配列の定義
 Set 写真URL索引 = Nothing '★連想配列を削除
のようにすれば連想配列を使えるからです。

 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://docs.microsoft.com/ja-jp/office/vba/language/reference/user-interface-help/dictionary-object★ を参照してください。

 下のコードは、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
...

キーとデータ(項目・値など)を対応表示する

Keys メソッドItems メソッド を使って対応出力できます。
Keys メソッド、Items メソッド で、下記のエラーが出る場合が有ります。
実行時エラー '451':
Property Let プロシージャが定義されておらず、Property Get プロシージャからオブジェクトが返されませんでした。

下記サイトで解決方法を公開していただいていたのでこれを利用したら、無事表示できました。

 一旦 Keys を Variant 変数に格納することが重要です。
http://blog.livedoor.jp/springjoe2/archives/52121849.html


   'Dictionary オブジェクトの内容を書き出す
   Dim varKeys As Variant
   Dim varItems As Variant
   varKeys = 項目索引.Keys
   varItems = 項目索引.Items
    
   For 処理行カウンタ = 0 To 項目索引.Count - 1
      Range("A2").Cells(1 + 処理行カウンタ, 1).Value = varKeys(処理行カウンタ)
      Range("B2").Cells(1 + 処理行カウンタ, 1).Value = varItems(処理行カウンタ)
   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

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

フォルダ内のファイル名の接頭辞で計数

 私は、韓国発のファッション・ブランド DHolic(ディーホリック) からダウンロードした美しいモデル写真が 1万枚以上たまりました。
 ホームページ (DHolic) から写真リンクを取得
 この写真ファイルを分割して「スクリーンセーバー」というフォルダにコピーして、ロック画面で使うために、このマクロを作成しました。
 一つ目のマクロは、ファイルの接頭辞(先頭桁数または接頭辞区分文字)でファイル数を集計するマクロです。ここで連想配列を使っています。
 二つ目のマクロは、このファイルを 200〜300 枚毎で、スクリーンセーバー・フォルダに入れ替えるものです。

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

Option Explicit
Option Base 1

'03:2023/05/27:区分文字を優先するように変更
'04:2023/06/06:区分文字2を追加

Sub ファイル名先頭文字でカウント()

   Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
   Dim ファイルオブジェクト As Object
   Dim フォルダパス As String
   Dim ファイルパス As String
   Dim 接頭辞カウント(2000, 2) As Variant
   Dim 接頭辞辞書 As Object '★連想配列
   Dim 拡張子 As String
   Dim 区分文字1 As String
   Dim 区分文字2 As String
   Dim 桁数 As Integer
   Dim ファイル名 As String
   Dim 文字目 As Integer
   Dim 接頭辞 As String
   Dim カウンタ As Integer
   Dim 最終行 As Integer

   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")

   Set 接頭辞辞書 = CreateObject("Scripting.Dictionary") '★連想配列の定義
   
   拡張子 = ThisWorkbook.Worksheets("スタート").Range("A2").Value
   区分文字1 = ThisWorkbook.Worksheets("スタート").Range("B2").Value
   区分文字2 = ThisWorkbook.Worksheets("スタート").Range("C2").Value
   桁数 = ThisWorkbook.Worksheets("スタート").Range("D2").Value
   カウンタ = 0
   
   '[ファイルを開く]ダイアログボックスで、ファイルを指定して、パスを取得
   ChDir ThisWorkbook.Path 'デフォルトのパスをこのExcelファイルのフォルダに変更
   ファイルパス = Application.GetOpenFilename(",*." & 拡張子)
   
   '[ファイルを開く]で「キャンセル」した場合は、処理を終了
   If ファイルパス = "False" Then End
   
   'ファイルパスから、フォルダパスを取得
   フォルダパス = ファイルシステムオブジェクト.GetParentFolderName(ファイルパス)

   '上で指定したフォルダ内の、全ての対象拡張子を検索
    For Each ファイルオブジェクト In ファイルシステムオブジェクト.GetFolder(フォルダパス).Files

      If 拡張子 = ファイルシステムオブジェクト.GetExtensionName(ファイルオブジェクト.Name) Then
         接頭辞 = ""
         ファイル名 = ファイルオブジェクト.Name
         For 文字目 = 1 To 桁数
            If Mid(ファイル名, 文字目, 1) = 区分文字1 _
            Or Mid(ファイル名, 文字目, 1) = 区分文字2 Then
               接頭辞 = Left(ファイル名, 文字目 - 1)
               Exit For
            End If
         Next 文字目
         
         If 接頭辞 = "" Then
            接頭辞 = Left(ファイル名, 桁数)
         End If
         
         
         If 接頭辞辞書.Exists(接頭辞) = False Then
            カウンタ = カウンタ + 1
            接頭辞辞書.Add 接頭辞, カウンタ
            接頭辞カウント(カウンタ, 1) = 接頭辞
            接頭辞カウント(カウンタ, 2) = 1
         Else
            接頭辞カウント(接頭辞辞書.Item(接頭辞), 2) = 接頭辞カウント(接頭辞辞書.Item(接頭辞), 2) + 1
         End If

      End If
   Next ファイルオブジェクト
   

   '既存データの2行目以降を行削除する
   Worksheets("接頭辞カウント").Activate
   'B 列(2列目)を基準に、最終行を求める
   最終行 = Cells(ActiveSheet.Rows.Count, 2).End(xlUp).Row
   If 最終行 > 1 Then
      Rows(2 & ":" & 最終行).Delete Shift:=xlUp '単純な Cells.Clear だとムダな空白行が残ってしまう
   End If
   '集計結果を登録
   ThisWorkbook.Worksheets("接頭辞カウント").Range("A1").Value = "接頭辞"
   ThisWorkbook.Worksheets("接頭辞カウント").Range("B1").Value = "カウント"
   ThisWorkbook.Worksheets("接頭辞カウント").Range("A2").Resize(カウンタ, 2) = 接頭辞カウント
   
   'カウントの降順でソート
   Range("A1").CurrentRegion.Sort _
      Key1:=Range("B2"), Order1:=xlDescending, _
      Header:=xlYes

   Set 接頭辞辞書 = Nothing '★連想配列を削除
   Set ファイルシステムオブジェクト = Nothing
   MsgBox "終了しました"

End Sub

Option Explicit

'05:2023/06/10:スクリーンセーバーに登録するファイル数を 300 で分割
Dim カウンタ As Integer


Sub スクリーンセーバー入替()

   カウンタ = 0

   Call 既存ファイル削除

   Do While カウンタ < 200
'   Stop
      Call 該当ファイルコピー
   Loop
   
   MsgBox "終了しました"

End Sub


Sub 既存ファイル削除()
   On Error Resume Next
   Kill "D:\www.dzimg.com\★スクリーンセーバー\*.jpg"

'https://vba-create.jp/vba-folder-file-delete/
End Sub


Sub 該当ファイルコピー()

   Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
   Dim ファイルオブジェクト As Object
   Dim フォルダパス As String
   Dim ファイルパス As String
   Dim ファイル名 As String
   Dim 接頭辞 As String
   Dim 最終行 As Integer
   Dim 既存ファイルフルパス As String
   Dim 出力ファイルフルパス As String
   Dim 分割 As String
   Dim 前回カウンタ As Integer

   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   
   '未処理接頭辞を検索する
   ThisWorkbook.Worksheets("接頭辞カウント").Activate
   'C 列(3列目)の最終行を求める
   最終行 = Cells(ActiveSheet.Rows.Count, 3).End(xlUp).Row
   
   If 最終行 = 1 Then
      最終行 = 2
   End If
   
   前回カウンタ = Range("C1").Cells(最終行, 1).Value
'   カウント = Range("B1").Cells(最終行, 1).Value

   If 前回カウンタ = 9999 Then
      最終行 = 最終行 + 1
      前回カウンタ = 0
   End If
   
   接頭辞 = Range("A1").Cells(最終行, 1).Value

   分割 = ""
'   Stop
   If Trim(接頭辞) = "" Then
      カウンタ = 9999
      GoTo 終了処理
   End If
   
   'この Excel ファイルパスをフォルダパスにする
   フォルダパス = ThisWorkbook.Path

   '上で指定したフォルダ内の、全ての対象拡張子を検索
    For Each ファイルオブジェクト In ファイルシステムオブジェクト.GetFolder(フォルダパス).Files

      ファイル名 = ファイルオブジェクト.Name
      If 接頭辞 = Left(ファイル名, Len(接頭辞)) Then
         
         既存ファイルフルパス = フォルダパス & "\" & ファイル名
         出力ファイルフルパス = "D:\www.dzimg.com\★スクリーンセーバー\" & ファイル名
'         Stop

         カウンタ = カウンタ + 1
         
         If カウンタ > 前回カウンタ + 300 Then
            分割 = "分割"
            Exit For
         End If

         If カウンタ > 前回カウンタ Then
            FileCopy 既存ファイルフルパス, 出力ファイルフルパス
         End If

      End If
   Next ファイルオブジェクト
   
'   Stop
   '処理結果を登録

   If 分割 = "" Then
      Worksheets("接頭辞カウント").Range("C1").Cells(最終行, 1).Value = 9999
   Else
      Worksheets("接頭辞カウント").Range("C1").Cells(最終行, 1).Value = カウンタ - 1
   End If

終了処理:
   
   Set ファイルシステムオブジェクト = Nothing

End Sub

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


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

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


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

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

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

 注意:Remove でコレクションから要素を削除すると、コレクションの Count プロパティを 1 減らします。
 コレクションで削除された要素の後に続く、すべての要素の Index 値も減らします。


 次の例は、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

Collectionの使用例
'https://excel-ubara.com/excelvba1/EXCELVBA358.html
 注意:key は省略可能です。省略すると各メンバの位置を表す数値(インデックス番号)が使われます。
 Key は任意の文字列を使えますが重複して add できません。
Option Explicit

Dim colls As New Collection

'または、以下のように、DimとSetを使う
'Dim colls As Collection
'Set colls = New Collection

Sub Collectionの使用例()

   With colls
       .Add Item:="アイテム1", Key:="key1"
       .Add Item:="アイテム2", Key:="key2"
       .Add Item:="アイテム3", Key:="key3"
       .Remove ("key3")
       .Add Item:="アイテム4", Key:="key4"
   End With
   
   MsgBox colls.Count '3と表示
   MsgBox colls(1) 'アイテム1と表示
   MsgBox colls.Item(2) 'アイテム2と表示
   MsgBox colls.Item(3) 'アイテム4と表示
   MsgBox colls("key4") 'アイテム4と表示

End Sub

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


九九の問題を生成(Collection使用)

 九九の問題を、ランダムな順で生成しようとおもってググってみたら、下記サイトで、まさしくこの回答のコードを紹介していただいていたので、そのまま使わせてもらいました。

重複のない乱数を作成するマクロ(Collection使用)
https://powervbadesktop.com/random1/

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

Option Explicit

'01:20230812:1を除外

'フィッシャー -イェーツのシャッフル
'https://ja.wikipedia.org/wiki/%E3%83%95%E3%82%A3%E3%83%83%E3%82%B7%E3%83%A3%E3%83%BC%E2%80%93%E3%82%A4%E3%82%A7%E3%83%BC%E3%83%84%E3%81%AE%E3%82%B7%E3%83%A3%E3%83%83%E3%83%95%E3%83%AB

Sub random5()
'連番からランダムに抜き出すコード(Collection)
'フィッシャーイェーツ
     
   Dim コレクション As Collection
   Dim i As Integer
   Dim シート As Worksheet
   Dim 出力セル As Range
   Dim j As Integer
   Dim インデックス番号 As Integer 'CollectionのIndex
    
   Const セル範囲 As String = "A1:H8" '九九問題表示の対象範囲
    
   Set コレクション = New Collection
   For i = 11 To 99
      If Right(CStr(i), 1) <> "0" And Right(CStr(i), 1) <> "1" _
      And Left(CStr(i), 1) <> "0" And Left(CStr(i), 1) <> "1" Then '二桁目 0 と 1 を除外。一桁目 0 と 1 を除外
'         Stop
         ' Addメソッドで要素を追加
         コレクション.Add i
         ' Collectionオブジェクト内に 11〜99(一桁目 0 以外)を格納します。
      End If
   Next i
    
   Set シート = ThisWorkbook.Worksheets(1)
   Set 出力セル = シート.Range(セル範囲)
    
   For j = 1 To 出力セル.Count
      ' RandBetween 関数は指定した整数の範囲で乱数を発生させます。 =RANDBETWEEN(0,10) のようにして、0 から 10 までのランダムな整数を取得できます。
      ' ここで指定している最大は、CollectionオブジェクトのCountを使っています。
      インデックス番号 = WorksheetFunction.RandBetween(1, コレクション.Count)
      ' 取得した数値=インデックス番号に対する要素を九九問題セルに出力します。
      出力セル(j).Value = コレクション(インデックス番号)
      ' Removeメソッドで要素を削除
      コレクション.Remove インデックス番号
      ' 抜き出した数値を削除していくことで重複のない乱数を実現
   Next
     
End Sub

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


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