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

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

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

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 のテキスト・ファイルをShiftJISで読むことに無理があった
'      Open 入力ファイル名 For Input As #1
'      '*************データの読み込み***********
'      Do While (EOF(1) = 0)
'         Line Input #1, 本文
'         '改行コードが、CR＋LF や CR コードで改行したファイルなら1行ずつ読めますが、
'         'LF で改行したファイルの場合、すべて1行目に読み込まれてしまいます。
'        ' vbLf（LF）で文字列を分割し、tmpLineListへ格納する
'         本文配列 = Split(本文, vbLf)
'         ' 本文配列の要素数でループ処理する。
'         For 行 = 0 To UBound(本文配列)
'            入力文字列 = 本文配列(行)
'            If Trim(入力文字列) <> "" Then
'               入力文字列 = Replace(入力文字列, vbTab, "")                     'タブ削除
'               入力文字列 = Replace(入力文字列, "_", "")                       '_削除
'               'vba “ (u201C) ”(u201D)を半角の " にしたい
'               入力文字列 = StrConv(入力文字列, vbNarrow)                      '全角文字を半角に変換
'               入力文字列 = Replace(入力文字列, "’", "'")                     '全角文字を半角に変換
'               入力文字列 = Replace(入力文字列, "‘", "'")                     '全角文字を半角に変換
'               入力文字列 = Replace(入力文字列, "“", """")                   '全角文字を半角に変換
'               入力文字列 = Replace(入力文字列, ChrW(&H201C), "")              '全角文字を半角に変換
'               入力文字列 = Replace(入力文字列, ChrW(&H201D), "")              '全角文字を半角に変換
'
'               If Left(入力文字列, 1) = "'" Or Left(入力文字列, 1) = """" Then '行頭の '、" 削除
'                  入力文字列 = Right(入力文字列, Len(入力文字列) - 1)
'               End If
'               If Len(入力文字列) > 0 Then
'                  Call 単語登録   '★★★★★
'               End If
'            End If
'            ' 最終行まで繰り返す
'         Next 行
'      Loop
'      Close #1
'

'      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

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

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

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

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

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

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

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
...

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
...

   '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 処理行カウンタ

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

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

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

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

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