Excel VBA 連想配列(ハッシュ テーブル)
連想配列を使って検索を高速化する
配列を使って、順次検索して照合する方法だと、データ件数が多くなると、相応して時間がかかります。
うまいやり方がないかと調べていて「連想配列(ハッシュ テーブル )」の存在を知りました。
下記サイトで、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.「日本語」シートで、!名前? をフィルタ抽出すると、辞書に存在しない登場人物?名を出力できます。
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(入力文字列, "–", "-") '文字コード変換
入力文字列 = Replace(入力文字列, "—", "-") '文字コード変換
入力文字列 = Replace(入力文字列, " ", " ") '文字コード変換
' 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
単純配列版
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
文字の出現頻度を数える
上で紹介した シーザー暗号 は、文字を他の文字に置き換えるものでしたが、換字暗号には、文字を他の記号に置き換えるものも、あります。
探偵小説 シャーロック・ホームズシリーズの「踊る人形」 の暗号は、換字暗号の一つです。
小説の中で、シャーロック・ホームズ は、英文中の文字の出現頻度から、「踊る人形」の暗号を解読します。
「踊る人形」の解読方法
http://www.comm.tcu.ac.jp/~math/hnakai/infomath/sherlockholmes/dance_decording.html
そこで、適当な長さの文章を指定して、文中に使われている文字の出現頻度を調べるマクロを、紹介します。
これは、Dictionary オブジェクト の典型的な使い方をデモする、プログラム例です。
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百万回 の照合作業が発生します。これでは、いくらパソコンの速度が速くても、それなりの時間がかかってしまいます。
「連想配列」を使って、「品目コード」に索引を付けると、直接アクセスできるので、飛躍的に速くなりました。
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 枚毎で、スクリーンセーバー・フォルダに入れ替えるものです。
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 オブジェクトにない、次のような特定の機能が含まれます。
Exists メソッド
このメソッドを使用して、特定のキーおよび対応するアイテムが Dictionary オブジェクトに含まれるかどうかを調べます。
Exists メソッドを使用すると、Collection オブジェクトの検索に比べて、Dictionary オブジェクトの検索がより簡単に、より効率的になります。
CompareMode プロパティ
このプロパティでは Object オブジェクトに対するテキスト比較のモードを指定するため、大文字小文字の区別を有効または無効にしてキーを検索できます。
既定では、BinaryCompare に設定され、Exists メソッドはバイナリ表示で一致するテキストが検索された場合にのみ True を返します。
Collection オブジェクトからアイテムを取得するキーに対して、テキスト比較のモードを指定することはできません。
Key プロパティ
このプロパティにより、ディクショナリ内の特定のアイテムに対するキーが返されます。
Collection オブジェクト内のアイテムにもキーが含まれます。このキーを使用してそのアイテムを取得できますが、キー自体を取得することはできません。
RemoveAll メソッド
このメソッドは、Dictionary オブジェクト内のすべてのアイテムを削除します。
Collection オブジェクトを Nothing に設定すると同時にすべてのアイテムを削除できますが、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/
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