ルビのフォントの種類を変更するFunction(Word)
ルビのフォントの種類を変えるFucntion
前々回
前回
のつづき。
今度は、ルビのフォントの種類を変える。
上記フィールドコード、
EQ \* jc2 \* "Font:ＭＳ 明朝" \* hps10 \o\ad(\s\up 10(ムーンサルト),月面宙返)のうち、
* "Font:ＭＳ 明朝"
のを変えればよいというのは一瞬でわかるだろう。。
コード
リスト１ 標準モジュール
Private Const STANDARD_RUBY_FONT As String = "ＭＳ 明朝" Private Function getChangedRubyFontNameFieldCodeText( _ ByVal targetFieldCodeText As String, _ Optional ByVal targetFontName As String = STANDARD_RUBY_FONT) As String Dim ret As String ret = targetFieldCodeText ret = getRepairedFieldCodeText(ret) '……(1)' Dim ar As Variant ar = Split(ret, "\") '" '……(2)' ar(2) = "* " & """Font:" & targetFontName & """ " ret = getAssembledFieldCodeText(ar) '……(3)' Finalizer: getChangedRubyFontNameFieldCodeText = ret End Function '【再掲】///SplitでバラしたFieldCodeを元通りにする' Private Function getAssembledFieldCodeText( _ ByRef splitFieldCode As Variant) As String Dim i As Long Dim ret As String For i = LBound(splitFieldCode) To UBound(splitFieldCode) ret = ret & splitFieldCode(i) & "\" '" Next ret = Left(ret, Len(ret) - 1) getAssembledFieldCodeText = ret End Function '【再掲】///手動で「中央揃え」にしたときのスイッチ省略への対応' Private Function getRepairedFieldCodeText( _ ByVal targetFieldCodeText) As String Dim ret As String ret = targetFieldCodeText Dim ar As Variant ar = Split(ret, "\") '" 'インデックスの最大値が「7」だったら、省略されていない。' If UBound(ar) = 7 Then GoTo Finalizer '省略を補う処理' ReDim Preserve ar(7) ar(7) = ar(6) ar(6) = ar(5) ar(5) = "ac(" ar(4) = "o" '手動で「中央揃え」にした後だと、 ar(4) の値が"o("になるときがある。' ret = getAssembledFieldCodeText(ar) Finalizer: getRepairedFieldCodeText = ret End Function
例によって、メインのFunctionから呼び出すことになる自作Fucntionについては再掲しておいた。
(1)の
ret = getRepairedFieldCodeText(ret)
で一旦フィールドコード文字列をチェック。手動で中央揃えしたときに一部省略されてしまう現象への対応。（今回の場合は実は必要ないんですが。）
(2)からの２行
ar = Split(ret, "\") '" ar(2) = "* " & """Font:" & targetFontName & """ "
で、フィールドコード文字列のうち、フォント名の指定にかかわる部分を書き換える。
２行目の
"""Font:" & targetFontName & """"
の部分で、なぜ"（ダブルクォーテーション）がずらずらと並べてあるのかよくわからない方は、
コチラをどうぞ。
あとは、(3)の
ret = getAssembledFieldCodeText(ar)
で、自作FunctiongetAssembledFieldCodeTextを用いてフィールドコード文字列を組み立て直してreturn。
使ってみる
次のコードで実験。
リスト２ 標準モジュール
Public Sub test01()
Dim targetField As Field
For Each targetField In Selection.Fields
With targetField
Dim str As String
If .Type = wdFieldFormula And _
(InStr(1, .Code.Text, "\s\up") > 0 Or _
InStr(1, .Code.Text, "\s\do") > 0) Then
.Code.Text = getChangedRubyFontNameFieldCodeText(.Code.Text, "ＭＳ ゴシック")
End If
End With
Next
End Sub
フォント名に「ＭＳ ゴシック」を指定する。
この状態で実行すると、
このとおり。フォントの種類が「ＭＳ ゴシック」になった。
フィールドコードはこのとおり。
おわりに
これで、ルビまわりのたいていのことは一括処理できる。
参考
ルビのサイズを変更するFunction(Word)
ルビのサイズを変えるFunction
前回
の続き。
ルビのサイズを変える
ルビのサイズを変えるには、
上記フィールドコード、
EQ \* jc2 \* "Font:ＭＳ 明朝" \* hps10 \o\ad(\s\up 10(ムーンサルト),月面宙返)のうち、
\* hps10
の値を変える。
「hps」というのは、前回も参照した
ワードの理解シリーズ様によると、
フォントの半分のポイント数(hpsは、half point sizeのhps)
とのこと。
従って、hps10なら、ルビのサイズは5ポイントだということだ。
コード
では、上記のことを踏まえてコーディング。
リスト１ 標準モジュール
Private Const MAX_RUBY_SIZE As Single = 20 '……(1)' Private Function getChangedRubySizeFieldCodeText( _ ByVal targetFieldCodeText As String, _ ByVal targetSize As Single) As String Dim ret As String ret = targetFieldCodeText If targetSize > MAX_RUBY_SIZE Then GoTo Finalizer '……(2)' ret = getRepairedFieldCodeText(ret) '……(3)' Dim ar As Variant ar = Split(targetFieldCodeText, "\") '……(4)' '" ar(3) = "* hps" & targetSize * 2 ret = getAssembledFieldCodeText(ar) '……(5)' Finalizer: getChangedRubySizeFieldCodeText = ret End Function '【再掲】///SplitでバラしたFieldCodeを元通りにする' Private Function getAssembledFieldCodeText( _ ByRef splitFieldCode As Variant) As String Dim i As Long Dim ret As String For i = LBound(splitFieldCode) To UBound(splitFieldCode) ret = ret & splitFieldCode(i) & "\" '" Next ret = Left(ret, Len(ret) - 1) getAssembledFieldCodeText = ret End Function '【再掲】///手動で「中央揃え」にしたときのスイッチ省略への対応' Private Function getRepairedFieldCodeText( _ ByVal targetFieldCodeText) As String Dim ret As String ret = targetFieldCodeText Dim ar As Variant ar = Split(ret, "\") '" 'インデックスの最大値が「7」だったら、省略されていない。' If UBound(ar) = 7 Then GoTo Finalizer '省略を補う処理' ReDim Preserve ar(7) ar(7) = ar(6) ar(6) = ar(5) ar(5) = "ac(" ar(4) = "o" '手動で「中央揃え」にした後だと、 ar(4) の値が"o("になるときがある。' ret = getAssembledFieldCodeText(ar) Finalizer: getRepairedFieldCodeText = ret End Function
今回のメインのFunctionから呼び出すことになる自作Functionは再掲した。
(1)の
Private Const MAX_RUBY_SIZE As Single = 20
は、ルビの最大サイズをとりあえず定数で設定。大きめにして20としたが、この辺はお好みで。
(2)の
If targetSize > MAX_RUBY_SIZE Then GoTo Finalizer
はガード節。引数で受け取ったサイズが、想定した最大サイズ（MAX_RUBY_SIZEの値）を超えていたら、Finalizerラベルまで飛んで、即リターンする。
(3)の
ret = getRepairedFieldCodeText(ret)
では、自作のgetRepairedFieldCodeTextで引数で受け取ったフィールドコードをチェック。
前回も書いたとおり、手動で「中央揃え」にすると、フィールドコードの一部が省略されてしまうので、もし省略されていたら、このFunctionで省略のない形に改める。
次に(4)からの２行
ar = Split(targetFieldCodeText, "\") '" ar(3) = "* hps" & targetSize * 2
で、一旦フィールドコードを部分にバラし、ルビのフォントサイズにかかわる部分（インデックス番号3の要素）を書き換える。
あとは、(5)の
ret = getAssembledFieldCodeText(ar)
で自作FunctionのgetAssembledFieldCodeTextを用いてフィールドコード文字列に組み立てて返り値用の変数retにぶち込む。
使ってみる
次のコードで実験。
リスト２ 標準モジュール
Public Sub test01()
Dim targetField As Field
For Each targetField In Selection.Fields
With targetField
Dim str As String
If .Type = wdFieldFormula And _
(InStr(1, .Code.Text, "\s\up") > 0 Or _
InStr(1, .Code.Text, "\s\do") > 0) Then
.Code.Text = getChangedRubySizeFieldCodeText(.Code.Text, 9#)
End If
End With
Next
End Sub
選択箇所のルビのフォントサイズを9に変えるコード。
ちなみに、現行のルビのフォントサイズは5。
このように、ルビが振られた部分を選択して実行すると、
このとおり。
フィールドコードを表示すると、
hpsの値が18になっているので、ルビのフォントサイズは9ということだ。
おわりに
文書の選択箇所のルビのフォントサイズを一括して変換するとか、そういう用途に使えそうです。
参考
ルビの割付を変更するFunction(Word)
ルビの割付を変更するFunction
正確に言えば、ルビの割付位置を変更した後のFieldオブジェクトのCode.Textプロパティの値を変更するFunctionです。
ルビの割付の変更
たとえば、
この「月面宙返」にルビを振る。
「ルビ」ダイアログボックスにこのように設定して、[OK]をクリックすると、
このように、ルビが振られる。
で、日本語入力をオフにして、[Alt] + [F9]を押すと、
このように、フィールドコードが表示される。
ちなみに、この場合のフィールドコードは、
EQ \* jc2 \* "Font:ＭＳ 明朝" \* hps10 \o\ad(\s\up 10(ムーンサルト),月面宙返)となっている。
フィールドコードの解読については、
コチラのサイトが非常に詳しく説明してくださっている。
ルビの割付に関わっているのは、
\* jc2 の部分（①）と、
\adの部分（②）。
フィールドコードの文字列は、FieldオブジェクトのCode.Textプロパティを参照すれば取得できるので、取得した文字列のうち、①と②を書き換えて、再設定してやればよい。
ルビの割付を変更するFunctionのコード
まず、列挙体を作っておく。
リスト１ 標準モジュール宣言セクション
'Enums' Private Enum AlignCode acAlignCenter = 0 '中央揃え' acAlignDistribution1 '均等割付1' acAlignDistribution2 '均等割付2' acAlignLeft '左揃え' acAlignRight '右揃え' End Enum
このように設定しておき、Functionの引数をAlignCode型にしておけば、引数の指定が楽かつわかりやすくなる。
次は、フィールドコード文字列点検用のFunction。
実は、均等割付絡みのフィールドコードのうち、②の方、すなわち
\adは、手動で「中央揃え」にすると、本来「\ac」となるはずが、省略されてしまうのである!!!!!!!!
こんなふうに手動で「中央揃え」に変更してみる。
すると、フィールドコードは、
ほらね。
こいつと比べると一目瞭然。
「\o」の後がいきなり「(s\up\」になっている。
これでは非常に困る。
従って、省略を補うFunctionを作った。
リスト２ 標準モジュール
Private Function getRepairedFieldCodeText( _
ByVal targetFieldCodeText) As String
Dim ret As String
ret = targetFieldCodeText
Dim ar As Variant
ar = Split(ret, "\") '"
'インデックスの最大値が「7」だったら、省略されていない。'
If UBound(ar) = 7 Then GoTo Finalizer
'省略を補う処理'
ReDim Preserve ar(7)
ar(7) = ar(6)
ar(6) = ar(5)
ar(5) = "ac("
'手動で「中央揃え」にした後は、 ar(4) の値が"o("になる。'
ar(4) = "o"
ret = getAssembledFieldCodeText(ar)
Finalizer:
getRepairedFieldCodeText = ret
End Function
Private Function getAssembledFieldCodeText( _
ByRef splitFieldCode As Variant) As String
Dim i As Long
Dim ret As String
For i = LBound(splitFieldCode) To UBound(splitFieldCode)
ret = ret & splitFieldCode(i) & "\" '"
Next
ret = Left(ret, Len(ret) - 1)
getAssembledFieldCodeText = ret
End Function
一旦、フィールドコード文字列を「\」をデリミタとしてSplit関数でバラしておき、必要な箇所を修正して再度組み立て直す、という処理にした。
ここまでで準備はおしまい。
あとは、メインのFunction。
リスト３ 標準モジュール
Private Function getConvertedAlignmentRubyFieldCodeText( _
ByVal targetFieldCodeText As String, _
ByVal targetAlignCode As AlignCode) As String
Dim ret As String
ret = targetFieldCodeText
If targetAlignCode < 0 Or _
targetAlignCode > 4 Then GoTo Finalizer '……(1)'
ret = getRepairedFieldCodeText(ret)
Dim alignSetting1 As String
Dim alignSetting2 As String
Select Case targetAlignCode '……(2)'
Case acAlignCenter
alignSetting1 = "* jc0 ": alignSetting2 = "ac("
Case acAlignDistribution1
alignSetting1 = "* jc1 ": alignSetting2 = "ad("
Case acAlignDistribution2
alignSetting1 = "* jc2 ": alignSetting2 = "ad("
Case acAlignLeft
alignSetting1 = "* jc3 ": alignSetting2 = "al("
Case acAlignRight
alignSetting1 = "* jc4 ": alignSetting2 = "ar("
End Select
Dim ar As Variant '……(3)'
ar = Split(ret, "\") '"
ar(1) = alignSetting1
ar(5) = alignSetting2
ret = getAssembledFieldCodeText(ar) '……(4)'
Finalizer:
getConvertedAlignmentRubyFieldCodeText = ret
End Function
(1)の
If targetAlignCode < 0 Or _ targetAlignCode > 4 Then GoTo Finalizer
はガード節。第２引数は列挙体にしたけれど、別に整数なら「5」でも「-3」でも渡せてしまうので、そういう予期せぬ値が渡されていたらここでシャットアウト。第１引数で渡された文字列をそのまま返すことにする。
(2)からの11行
Select Case targetAlignCode
Case acAlignCenter
alignSetting1 = "* jc0 ": alignSetting2 = "ac("
Case acAlignDistribution1
alignSetting1 = "* jc1 ": alignSetting2 = "ad("
Case acAlignDistribution2
alignSetting1 = "* jc2 ": alignSetting2 = "ad("
Case acAlignLeft
alignSetting1 = "* jc3 ": alignSetting2 = "al("
Case acAlignRight
alignSetting1 = "* jc4 ": alignSetting2 = "ar("
End Select
では、第２引数に応じて、均等割付の種類に応じた２箇所の文字列を変数にぶち込んでいる。
(3)からの４行
Dim ar As Variant ar = Split(ret, "\") '" ar(1) = alignSetting1 ar(5) = alignSetting2
では、Split関数で一旦フィールドコード文字列をバラし、インデックス「1」と「5」の要素を書き換える。
あとは(4)の
ret = getAssembledFieldCodeText(ar)
で、リスト２のgetAssembledFieldCodeTextメソッドを用いて、再びフィールドコード文字列を組み立て直しておしまい。
使ってみる
次のコードで実験。
リスト４ 標準モジュール
Public Sub test01()
Dim targetField As Field
For Each targetField In Selection.Fields
With targetField
If .Type = wdFieldFormula And _
(InStr(1, .Code.Text, "\s\up") > 0 Or _
InStr(1, .Code.Text, "\s\do") > 0) Then '……(5)'
.Code.Text = getConvertedAlignmentRubyFieldCodeText( _
.Code.Text, acAlignLeft) '……(*)'
End If
End With
Next
End Sub
選択範囲のFieldオブジェクトを総当たりにする方式。
したがって、(5)の
If .Type = wdFieldFormula And _
(InStr(1, .Code.Text, "\s\up") > 0 Or _
InStr(1, .Code.Text, "\s\do") > 0) Then
で、ルビのためのフィールドなのかどうかを判定する。
ルビ用のフィールドコードの特徴は、「\s\up」（上付き）か（手動で設定できないからめったに見かけないけど）「\s\do」（下付き）のどちらかが含まれていることなので、このような条件式にした。
実行結果
(*)のところでgetConvertedAlignmentRubyFieldCodeTextメソッドに渡した第２引数がacAlignLeftなので、
当然こうなる。
(*)を
.Code.Text = getConvertedAlignmentRubyFieldCodeText( _
.Code.Text, acAlignRight)
に変えると、
こうなって、
.Code.Text = getConvertedAlignmentRubyFieldCodeText( _
.Code.Text, acAlignCenter)
こうすると、
こうなる。
おわりに
Wordのルビ周りは、フィールドコードが絡むこともあって、なかなか気軽には手を出しにくい領域だったが、ワードの理解シリーズ様のおかげで、だいぶ理解が進んだと思う。
ここまで下準備ができていれば、ルビのフォントを変えたり、サイズを変えたりするぐらいなら楽勝です。
参考
コチラもどうぞ。
検索速度の測定 再び……
検索速度の測定再び……
前回
ご紹介したように、UsedRangeまわりのExcelの挙動について重大な思い違いをしていたことに気付いた私は、心を入れ替えて実験をし直すことにした。
実験環境の再整備
まず、イミディエイト・ウインドウ上で
Activesheet.Range(Activesheet.Cells(1 ,1),Activesheet.Cells(1000, 1000)).Value = "hoge"
を実行し、
このような環境とした。
続けて、
このように、ALL1000セルに「ち～んｗ」という値（笑）を入力した。
これで、実験環境は整った。
念のために、イミディエイト・ウインドウ上で
?Activesheet.UsedRange.Address?Activesheet.UsedRange.Count?Activesheet.UsedRange.Cells.Count
これらのコードを実行し、結果を見てみる。
うむ。UsedRangeプロパティが1000×1000の範囲になっておる！
この状態で、前回記事のリスト１を実行する。
実行結果
まず、
この状態、すなわちALL1001セルにカーソルを置いた状態で実行してみる。
結果は、
このとおり。
1000×1000のセル範囲のセルのValueプロパティを一つ一つ調べる方式
5.343秒。
1000×1000のセル範囲のRangeオブジェクトのValueプロパティの値を一旦二次元配列にぶち込んで、同じく一つ一つ調べる方式
1.563秒。
1000×1000のセル範囲に対してExcelのFindメソッドを使う方式
0.844秒。
結局、〈総ナメ＞2次元配列＞Findメソッド〉という順序は変わっていない。
次に、
この状態、すなわちALL1000セルにカーソルを置いた状態で実行してみる。
結果は、
このとおり。
1000×1000のセル範囲のセルのValueプロパティを一つ一つ調べる方式
4.813秒。
1000×1000のセル範囲のRangeオブジェクトのValueプロパティの値を一旦二次元配列にぶち込んで、同じく一つ一つ調べる方式
0.906秒。
1000×1000のセル範囲に対してExcelのFindメソッドを使う方式
0.891秒。
やはり、〈総ナメ＞2次元配列＞Findメソッド〉という順序は変わっていない。
最後に、
この状態、すなわちA1セルにカーソルを置いた状態で実行してみた。
結果は、
このとおり。
1000×1000のセル範囲のセルのValueプロパティを一つ一つ調べる方式
4.797秒。
1000×1000のセル範囲のRangeオブジェクトのValueプロパティの値を一旦二次元配列にぶち込んで、同じく一つ一つ調べる方式
1秒。
1000×1000のセル範囲に対してExcelのFindメソッドを使う方式
0.921秒。
やはり、〈総ナメ＞2次元配列＞Findメソッド〉という順序は変わらなかった。
おわりに
通常、このようなテストは、何回も繰り返して平均を取るとかするものなので、実験結果に大した意味はないと思いますが、一つ一つのセルにアクセスする方式が論外なのはともかく、2次元配列総ナメ方式とFindメソッド方式なら、平均すれば2次元配列総ナメ方式が速度面では有利だと思いました。
今回の実験のやり方だと、総ナメ方式には不利（値発見＝Forループ完走なので。）だもんね。
Worksheet.UsedRangeに関する衝撃の事実（大袈裟）
Worksheet.UsedRangeプロパティに関する衝撃の事実（大袈裟）
はけたさんの一言
Twitterで、はけたさんが、
こんなことをおっしゃっていたので、実験してみた。
UsedRangeとは何なのか
まず、
このときに使用した
このシートのUsedRangeプロパティについて調べてみた。
イミディエイト・ウインドウに、次のコードを打ち込んで結果を見る。
?Activesheet.UsedRange.Address?Activesheet.UsedRange.Count?Activesheet.UsedRange.Cells.Count
実行結果は、
なんと！
ALL1000セルに値を入れたら、てっきり$A$1:$ALL$1000の範囲がUsedRangeになると思い込んでいたけれど、ALL1000セル一つだけなんだ……。
おわりに
「Used」状態の「Range」なのだから、当たり前なのであった……orz
検索の速度を測ってみた
検索の所要時間を調べた
ちょっと興味があったので、調べてみた。
このように、1000行1000列目のセル、すなわちALL1000セルに「ち～んｗ」という値（笑）を入力したシートを準備する。
で、この「ち～んｗ」を検索するのにどのぐらい時間がかかるものなのか、測ってみたわけである。
検索方法
私は所詮素人なので、次の三つの方法を用いた。
- 1000×1000のセル範囲のセルの
Valueプロパティを一つ一つ調べる方式 - 1000×1000のセル範囲の
RangeオブジェクトのValueプロパティの値を一旦二次元配列にぶち込んで、同じく一つ一つ調べる方式 - 1000×1000のセル範囲に対してExcelの
Findメソッドを使う方式
以上三つである。
実験用のコード
下記のコードを用いる。
時間計測用に、自作のWindowsAPIクラスを用いているが、これについては、
コチラをどうぞ。WindowsAPI.callGetTickCountメソッドというのは、WindowsAPIのGetTickCountを利用するメソッドです。
リスト１ 標準モジュール
'エントリポイント。' Public Sub testSearch() '自作WindowsAPIクラスのインスタンスを用意。' Dim winAPI As New WindowsAPI 'セルを一つ一つ巡回する方式の時間を表示する。' Dim startTime As Long startTime = winAPI.callGetTickCount Dim ret As Boolean ret = testSearchByNormalForLoop Dim elapsedTime As Double elapsedTime = winAPI.callGetTickCount - startTime Call showResult(ret, "testSearchByNormalForLoop", elapsedTime) '二次元配列にぶち込んで一つ一つ巡回する方式の時間を表示する。' startTime = winAPI.callGetTickCount ret = testSearchBy2DimensionArray elapsedTime = winAPI.callGetTickCount - startTime Call showResult(ret, "testSearchBy2DimensionArray", elapsedTime) 'ExcelのFindメソッドを使う方式の時間を表示する。' startTime = winAPI.callGetTickCount ret = testSearchByFindMethod elapsedTime = winAPI.callGetTickCount - startTime Call showResult(ret, "testSearchByFindMethod", elapsedTime) End Sub '計測結果を表示するためのメソッド。' Private Sub showResult(ByVal isSuccessed As Boolean, _ ByVal methodName As String, _ ByVal elapsedTime As Double) Debug.Print methodName & " の結果：" If isSuccessed Then Debug.Print "「ち～んｗ」を みつけた！" Else Debug.Print "見つけられなかった……。" End If Debug.Print elapsedTime / 1000 & "秒かかった！" Debug.Print String(20, "=") End Sub 'セルを一つ一つ巡回する方式。' Public Function testSearchByNormalForLoop() As Boolean ' Dim ret As Boolean' ' ret = False' testSearchByNormalForLoop = False Dim sh As Worksheet Set sh = ActiveSheet Dim r As Long Dim c As Long For r = 1 To 1000 For c = 1 To 1000 If sh.Cells(r, c).Value = "ち～んｗ" Then _ ' ret = True: Exit For' '///アホすぎる誤りを修正' testSearchByNormalForLoop = True: _ Exit Function Next Next ' If ret Then testSearchByNormalForLoop = True' End Function '一旦二次元配列にぶち込んで一つ一つ巡回する方式。' Public Function testSearchBy2DimensionArray() As Boolean ' Dim ret As Boolean' ' ret = False' testSearchBy2DimensionArray = False Dim sh As Worksheet Set sh = ActiveSheet Dim rng As Range With sh Set rng = .Range(.Cells(1, 1), _ .Cells(1000, 1000)) End With Dim ar As Variant ar = rng.Value Dim r As Long Dim c As Long For r = 1 To 1000 For c = 1 To 1000 If ar(r, c) = "ち～んｗ" Then _ ' ret = True: Exit For' '///アホすぎる誤りを修正' testSearchBy2DimensionArray = True: _ Exit Function Next Next ' If ret Then testSearchBy2DimensionArray = True' End Function 'ExcelのFindメソッドを使う方式。' Public Function testSearchByFindMethod() As Boolean Dim ret As Boolean ret = False Dim sh As Worksheet Set sh = ActiveSheet Dim rng As Range With sh Set rng = .Range(.Cells(1, 1), _ .Cells(1000, 1000)).Find(what:="ち～んｗ") End With If Not rng Is Nothing Then ret = True testSearchByFindMethod = ret End Function
処理内容はコード内のコメントの通り。行数の割に中身はないｗ
追記
2018/1/19
コード中、あまりにアホ過ぎる誤りに気付いたので、修正しました。実は、うｐした次の日には気付いていたのですが、連休が明けると本業の方が絶讃炎上中となっておりまして、連日アレな感じだったために修正ができなかったのです。
修正箇所は、リスト内にコメントで記した通りです。
実行結果
ご覧の通り。
1000×1000のセル範囲のセルのValueプロパティを一つ一つ調べる方式
4.016秒。
1000×1000のセル範囲のRangeオブジェクトのValueプロパティの値を一旦二次元配列にぶち込んで、同じく一つ一つ調べる方式
0.235秒。
1000×1000のセル範囲に対してExcelのFindメソッドを使う方式
0.015秒。
なんと、まさにケタ違い。
ちょっとビックリの結果。
まあ、一つ目、二つ目については、一番時間がかかるところに値（笑）を配置するという意地悪な実験なんですが。
しかし、こうなると、ExcelのFindメソッドの実装がどうなっとるのか、非常に気になるのであります。
乱数を作るクラスを改良した
乱数を作るクラス
ランダムに並べ替える作業というのは滅多にないのだけれど、絶妙に忘れかけた頃に発生するので、
このときにクラスまで作っていた。
んで、改めて見直してみたら、イマイチやなあ、と（笑）。
そんなわけで、作り直してみた。
乱数を作るクラスの改良
前に作ったやつは、あくまでも「１～最大数」をランダムに並べ替えるというだけだった。
そこで、今回は、
- 最小値と最小値を指定できるようにする
- 要素数を指定できるようにする
の２点を追加することにした。
あと、クラス名とか変数名、プロパティ名も大幅に見直した。
コード
さっそく、クラスモジュールのコードを示す。
クラス名は「RandomNumbers」に変えた。
リスト１ クラスモジュール
Option Explicit
'Variables'
Private Item_() As Long
'Properties'
Public Property Get Item(ByVal i As Long) As Long
Item = Item_(i)
End Property
Public Property Get Count() As Long
Count = UBound(Item_) + 1
End Property
'Constructor'
Private Sub Class_Initialize()
ReDim Item_(0)
Item_(0) = 1
End Sub
'Methods'
Public Sub setRandomNumbers(ByVal maxNum As Long, _
ByVal countOfElements As Long, _
Optional ByVal minNum As Long = 1, _
Optional ByVal hasDuplicate As Boolean = False)
'///minNum～maxNumまでの整数をランダムに並べて配列に格納する。'
'///引数maxNum：最大数'
'///引数countOfElements：出来上がりの要素数'
'///引数minNum：最小数'
'///引数hasDuplicate：重複を許可するならTrue'
'///ただし、要素数が数値の種類数（maxNum-minNum+1）より大きいときは、'
'///Falseが渡されてもTrueに変える。'
If countOfElements > maxNum - minNum + 1 Then _
hasDuplicate = True
Dim isUsed() As Boolean
ReDim isUsed(countOfElements - 1)
Dim i As Long
ReDim Item_(countOfElements - 1)
Randomize
Dim tmp As Long
For i = 0 To countOfElements - 1
Do
tmp = Int((maxNum - minNum + 1) * Rnd + minNum)
'///乱数：Int((最大値 - 最小値 + 1) * Rnd + 最小値)'
Loop Until isUsed(tmp - minNum) = False
Item_(i) = tmp
If Not hasDuplicate Then isUsed(tmp - minNum) = True
Next
End Sub
まあ、大枠では変えていないので、説明は省略ｗ
使ってみる
次のコードで実験。
リスト２ 標準モジュール
Public Sub testRandomNumbers()
Dim rndNums As New RandomNumbers
With rndNums
Call .setRandomNumbers(10, 10, 1, False) '……(1)'
Dim i As Long
For i = 0 To .Count - 1
Debug.Print .Item(i)
Next
Debug.Print String(5, "=")
Call .setRandomNumbers(20, 20, 11, True) '……(2)'
For i = 0 To .Count - 1
Debug.Print .Item(i)
Next
End With
End Sub
setRandomNumbersメソッドを２回呼び出して、それぞれ取得したランダムな数列をイミディエイトに書き出すだけのコード。
(1)の
Call .setRandomNumbers(10, 10, 1, False)
では、
最大値10（第１引数）、最小値1（第３引数）で、重複を許さず（第４引数）に、ランダムに並べた10個（第２引数）の数字を得ることになる。
同様に、(2)の
Call .setRandomNumbers(20, 20, 11, True)
では、
最大値20（第１引数）、最小値11（第３引数）で、重複を許して（第４引数）、ランダムに並べた20個（第２引数）の数字を得ることになる。
ちなみに、(2)で
Call .setRandomNumbers(20, 20, 11, False)
と、第４引数をFalseにしたとしても、setRandomNumbersメソッド内部でTrueに変えるようにしてある。（リスト１参照）
これは、たとえば「1～5を重複しないようにランダムに10個並べろ！」とか言われても、
そんなの、デキッコナイス！
となるに決まっているからである。
実行結果
この通り。
うまくいっている。
おわりに
これに、あとひと工夫すれば、
こんなふうに、記号をランダムに散らす、といったことに使えます。
学校の先生なんかが、記号式のテスト問題の解答をテキトーに散らすのに使えるんじゃないですかね。
あとは、競輪の出目予想とかｗ
