乱数を格納した配列を作るFunction

文字をランダムに並べ替える

乱数を作るのはめんどくさい

ランダムに並べ替えるという作業をするときには、乱数を発生させて使えば良いのだが、毎度毎度乱数を発生させる処理を書くのは正直メンドクサイ。

最大数を与えたら、1~最大数をランダムに並べて配列にぶち込んでくれるような関数でもあれば、その配列を0~最大数マイナス1の順で呼び出してコレクションのインデックスにすることによって、コレクションをランダムに並べ替えて出力することが可能になると考えた。

ランダムに並べ替えて配列にぶち込むFunction

リスト1 標準モジュール
Public Function createRandomArray( _
                  ByVal maxNum As Integer, _
                  ByVal allowDuplicate As Boolean) _
                    As Variant    '……(1)'
  Dim flg() As Boolean
  ReDim flg(maxNum - 1)    '……(2)'
  Dim i As Integer
  Dim retArray() As Integer    '……(3)'
  ReDim retArray(maxNum - 1)
  Randomize
  Dim tmp As Integer
  For i = 0 To maxNum - 1
    Do
      tmp = Int(maxNum * Rnd + 1)    '……(4)'
    '///乱数:Int((最大値 - 最小値 + 1) * Rnd + 最小値)'
    Loop Until flg(tmp - 1) = False    '……(5)'
    retArray(i) = tmp    '……(6)'
    If Not allowDuplicate Then flg(tmp - 1) = True    '……(7)'
  Next
  createRandomArray = retArray    '……(8)'
End Function

ちょっとめんどくさいけれど、自分の備忘のためにも説明を書いておく。

(1)の

Public Function createRandomArray( _
                  ByVal maxNum As Integer, _
                  ByVal allowDuplicate As Boolean) _
                    As Variant

引数maxNumは最大数。たとえば、こいつを10にしたら、1~10までをランダムに取り出して要素数10の配列にぶち込んでいくということ。

引数allowDuplicateは、番号の重複を許可するかどうか。Trueにすると重複無しで配列を作成。Falseにすると重複ありで配列を作成することになる。Falseを指定する場面があるのかどうかは不明。

返り値の型はVariantにした。最初Integerにしていたんだけれど、「型が一致しません」エラーが出て対応策が分からなかったので。

(2)の

ReDim flg(maxNum - 1)

では、引数で渡されたmaxNumを用いて配列変数flgをRedimしている。はじめから

Dim flg(maxNum - 1) As Boolean

でうまく行きそうなもんだが、こうすると「定数式が必要です」エラーが出る。

(3)の

Dim retArray() As Integer

は、返り値用の配列変数。createRandomArrayを配列みたいにして直接値をぶち込んで行くことができないので、一旦配列を作っておいて、完成後この配列を返す、という形を取る。

(4)の

tmp = Int(maxNum * Rnd + 1)

で、一旦1~maxNumの範囲の整数をランダムに生み出して変数tmpに格納する。

(5)の

Loop Until flg(tmp - 1) = False

でDo~Loopの終了条件を指定している。

たとえば、tmpに10が入っているとすると、flg(10-1)、すなわち配列変数flg()の10番目の要素がfalseだったらループを抜けるということ。

ループを抜けると、(6)の

retArray(i) = tmp

で配列変数retArrayにtmpの値をぶち込み、(7)の

If Not allowDuplicate Then flg(tmp - 1) = True

で、重複を許可しない場合に限ってflg(tmp - 1)、すなわちtmpが10の場合は配列変数flg()の10番目をTrueに変える。

こうすることで、この後仮に(4)で10がtmpに代入されたとしても、(5)のループ終了条件を満たさなくなる。すなわち、この後10が配列変数retArrayの要素になることはないということ。

こうして、Forループが終了すると配列変数retArrayには1~maxNumまでの整数がランダムにぶち込まれていることになるので、後は(8)の

createRandomArray = retArray

で配列retArrayを返しておしまい。

実行

標準モジュールに下記のコードを書いて実行してみる。

スト2 標準モジュール
Public Sub test()
  Dim a As Variant
  a = createRandomArray(10, False)
  Dim i As Integer
  For i = 0 To 9
    Debug.Print a(i)
  Next
End Sub

f:id:akashi_keirin:20171021230753j:plain

この通り、無事に1~10が重複無しのランダムに並んでいる。

選択範囲の単語をランダムに並べ替える

自作Function「createRandomArray」を利用して、選択範囲の単語をランダムに並べ替えるマクロを作ってみる。

リスト3 標準モジュール
Public Sub randomSortByWord()
  Dim num As Long
  Dim wordsArray() As String
  With Selection
    num = .Words.Count    '……(1)'
    ReDim wordsArray(num - 1)    '……(2)'
    Dim i As Integer
    For i = 0 To num - 1    '……(3)'
      wordsArray(i) = .Words(i + 1)
    Next
  End With
  Dim wordsOrder As Variant
  wordsOrder = createRandomArray(num, False)    '……(4)'
  Dim str As String
  For i = 0 To num - 1    '……(5)'
    str = str & wordsArray(wordsOrder(i) - 1)
  Next
  Selection.TypeText Text:=str    '……(6)'
End Sub

(1)の

num = .Words.Count

では、変数numにSelectionオブジェクト(この場合は選択範囲)のWordsコレクションのCountプロパティを参照することで選択範囲の「単語数」を取得し、変数numにぶち込んでいる。

(2)では、(1)で得られた単語数をもとに配列変数wordsArray()をRedim。

(3)からの3行

For i = 0 To num - 1    '……(3)'
  wordsArray(i) = .Words(i + 1)
Next

で、一旦選択範囲の各単語を配列に格納。配列のインデックスは0から始まるけれど、Wordsコレクションのインデックスは1から始まるので、Wordsコレクションのインデックスのところは「i + 1」になる。

(4)の

wordsOrder = createRandomArray(num, False)

では、単語を取り出す順番を格納する配列変数wordsOrderにcreateRandomArray関数の返り値を格納。

これで配列変数wordsOrderには1~単語数のそれぞれの数字がランダムな順番で格納されることになる。

(5)からの3行

For i = 0 To num - 1    '……(5)'
  str = str & wordsArray(wordsOrder(i) - 1)
Next

では、変数strに配列変数wordsArrayに格納されている単語を1つづつ配列変数wordsOrderの要素で指定して取り出し、連結していく。

Forループが終了した時点で、strには、単語をランダムに並べ替えた文字列が完成していることになる。

んで最後に(6)の

Selection.TypeText Text:=str

で、SelectionオブジェクトのTypeTextメソッドを用いてstrに格納された文字列を書き込んでおしまい。

SelectionオブジェクトのTypeTextメソッドは、文字列が選択された状態で実行すると、選択範囲を引数Textで指定された文字列で上書きする。

実行結果

f:id:akashi_keirin:20171021230805j:plain

こんなふうに文字列を選択状態にして実行すると、

f:id:akashi_keirin:20171021230815j:plain

このようになる。

悲しいかな、「単語」と言っても、「Wordが認識する単語」に過ぎず、結果はめちゃくちゃである。

おわりに

今回はFunctionでやってみたが、Functionの返り値がVariant型になってしまったり、その結果、呼び出す側でも変数をVariantにしないといけないというのは何ともブサイクなので、イマイチだなあと思ってしまう。

クラスにした方がキレイに書けるかも知れない。

相変わらず使い道があるのかどうかはよく分からないw

@akashi_keirin on Twitter

ユーザーフォームへのコントロールの動的配置

コンボボックスを動的に追加する

フォームにコンボボックスを追加する

コンボボックスやリストボックスは、ユーザからの入力を受け付けるインターフェースとしては便利なんだが、チマチマ作ることを思うと結構メンドクサイ。

コンボボックスの追加がラクにできたらいいなあ、と思い、ちょっと実験してみた。

まずは、フォームを挿入する。今回はオブジェクト名を「FormTest02」としてある。

リスト1 フォームモジュール
Private srcRange_() As Range    '……(*)'
Private cmbBox_() As MSForms.ComboBox
Private numOfCombos_ As Integer

Public Sub createComboBox( _
             ByVal posTop As Double, _
             ByVal posLeft As Double, _
             ByVal meHight As Double, _
             ByVal meWidth As Double, _
             ByVal srcRange As Range)    '……(1)'
  numOfCombos_ = numOfCombos_ + 1    '……(2)'
  ReDim Preserve srcRange_(numOfCombos_ - 1)
  Set srcRange_(numOfCombos_ - 1) = srcRange
  ReDim Preserve cmbBox_(numOfCombos_ - 1)    '……(3)'
  Set cmbBox_(numOfCombos_ - 1) = _
      Controls.Add("Forms.ComboBox.1", "cmbBox" & numOfCombos_, True)    '……(4)'
  With cmbBox_(numOfCombos_ - 1)    '……(5)'
    .top = posTop    '……(6)'
    .left = posLeft
    .height = meHight
    .width = meWidth
    Dim i As Integer
    For i = 0 To srcRange_(numOfCombos_ - 1).Rows.Count - 1    '……(7)'
      .AddItem srcRange.Cells(i + 1, 1).Value
    Next
  End With
End Sub

まずは、宣言セクションの(*)からの3行

Private srcRange_() As Range
Private cmbBox_() As MSForms.ComboBox
Private numOfCombos_ As Integer

3つのPrivate変数を宣言。

srcRange_は、コンボボックスのデータソースになるセル範囲を入れておく変数。複数になることを想定して配列にしている。

cmbBox_()は、動的に生成したコンボボックスを格納しておく変数。これまた複数になることを想定して配列にしている。

numOfCombos_は生成されたコンボボックスの数を記録するための変数。

(1)では、コンボボックスを生成するためのcreateComboBoxメソッドを定義。

とりあえず5つの引数を受け取ってコンボボックスを作成することにする。

それぞれの引数の役割は、以下の通り。

  • ・posTopはフォーム上のタテ位置。
  • ・posLeftはフォーム上のヨコ位置。
  • ・meHeightはコンボボックスの高さ。
  • ・meWidthはコンボボックスの幅。
  • ・srcRangeはデータソースになるセル範囲。

実際にはもっと細かく指定しないと使い物にならないけれど、今回はとりあえずの実験なのでこのぐらいで勘弁してほしい。

(2)の

numOfCombos_ = numOfCombos_ + 1

では、このメソッドが呼び出されるごとにnumOfCombos_をインクリメント。こうすることで、生成されたコンボボックスを番号で指定できるようにする。

(3)の

ReDim Preserve cmbBox_(numOfCombos_ - 1)

で、生成したコンボボックスを格納するための配列変数をReDimする。前に格納していたコンボボックスが消えないように、Preserveしている。

(4)の

Set cmbBox_(numOfCombos_ - 1) = _
      Controls.Add("Forms.ComboBox.1", "cmbBox" & numOfCombos_, True)

では、ControlsコレクションのAddメソッドを用いて、配列変数cmbBox_()に新たに生成したコンボボックスを格納。

Newできたら分かりやすいのになあ。

(5)からは、

With cmbBox_(numOfCombos_ - 1)

このように、「cmbBox_(numOfCombos_ - 1)」をWithで括ることによって、新たに追加したコンボボックスへの設定を行う。

ただし、(6)からの4行

.top = posTop
.left = posLeft
.height = meHight
.width = meWidth

なんかヘンだと思いませんか?

実は、インテリセンスが働かず、

f:id:akashi_keirin:20171009182628j:plain

このように入力候補にも出てこないのです。

んで、改行しても頭文字が小文字のまま。メチャクチャ不安になりますな。

あとは、(7)からの3行

For i = 0 To srcRange_(numOfCombos_ - 1).Rows.Count - 1
  .AddItem srcRange.Cells(i + 1, 1).Value
Next

AddItemメソッドでドロップダウンリストにsrcRangeからデータを追加している。

ホントは、Listプロパティを設定して複数列リストに対応しないといけないんだけれど、今回は実験ということで1列で勘弁してほしい。

実行

標準モジュールに次のコードを書いて実行する。

スト2 標準モジュール
Public Sub exhibition()
  Dim frm As TestForm02    '……(1)'
  Set frm = New TestForm02
  With frm
    .createComboBox 10, 30, 20, 80, ActiveSheet.Range("B2:B7")    '……(2)'
    .createComboBox 10, 130, 20, 80, ActiveSheet.Range("C2:C7")
    .Show    '……(3)'
  End With
End Sub

まず、(1)からの2行

Dim frm As TestForm02
Set frm = New TestForm02

TestForm02型の変数frmにTestForm02のインスタンスを格納。

(2)からの2行は、WithでまとめているのでいづれもTestForm02のインスタンスに対する処理。

.createComboBox 10, 30, 20, 80, ActiveSheet.Range("B2:B7")
.createComboBox 10, 130, 20, 80, ActiveSheet.Range("C2:C7")

createComboBoxメソッドを、引数を変えて2回呼び出している。

で、(3)の

.Show

でフォームを表示しておしまい。

実行結果

f:id:akashi_keirin:20171009182641j:plain

このように2つのコンボボックスが設置されたフォームが表示され、

f:id:akashi_keirin:20171009182651j:plain

左側のコンボボックスにはB列のデータが、

f:id:akashi_keirin:20171009182704j:plain

右側のコンボボックスにはC列のデータが入っている。

おわりに

これだけではまるで使い道がないし、使い物になるコンボボックスにするためには設定すべきプロパティがメチャクチャたくさんあるので、普通にメソッドに引数を渡すような実行方法は現実的でないと思う。

たとえば、ワークシートにコンボボックスの細かい仕様を表す表を作成しておいて、そこから値を読み込んでプロパティを設定するというやり方になりそうだ。

あと、イベントを検知できなければ使い物にならないので、WithEventsキーワードの使い方についてもこれから研究していく必要がある。

けっこう面白いかも知れないなあ。

【参考】

akashi-keirin.hatenablog.com

差込印刷のデータソースにおけるVLOOKUP関数の使用――(2)

差込印刷のデータソースにおけるVLOOKUP関数

akashi-keirin.hatenablog.com

この続き。

問題は戻り値の「0」(ゼロ)

差込印刷のデータソースの表でVLOOKUP関数を使うと、検索値によって差し込みたいデータが決まっているようなときは非常に都合が良い。

ただ、前回も述べたように、空白を返したいときでも、戻り値は「0」(ゼロ)になってしまうため、差し込みフィールドに「0」が差し込まれてしまう。

前回は、「0」を表示させないためにフィールドコードでIF文を用いたが、改段落が残ってしまうため、非常にぶさいくな仕上がりになってしまう。

VLOOKUP関数の戻り値「0」を「""」に置き換える

ならば、と戻り値が「0」のときにそれを「""」(空白文字列)に置き換えることを考える。

理屈は簡単。IF関数でVLOOKUP関数の戻り値が「0」の場合に「""」にするようにすれば良い。

ただ、ただでさえ引数部分がクソ長ったらしくなるVLOOKUP関数をIF関数でネストするわけだから、ちょっとした下ごしらえは必要。

まず、表引きの元になる表に、

f:id:akashi_keirin:20171008212725j:plain

こんなふうに、「競輪場一覧」と名前を付けた。これでVLOOKUP関数の第2引数はぐっと簡単になる。

んで、差込データソースの表のB列以降には、たとえば

f:id:akashi_keirin:20171008212734j:plain

こんなふうに、

=IFERROR(
   IF(VLOOKUP($A2,競輪場一覧,COLUMN(Sheet1!B$1),FALSE)=0,
     "",
     VLOOKUP($A2,競輪場一覧,COLUMN(Sheet1!B$1),FALSE)
   ),
 ""
 )

あまりにも長すぎるのでインデントしてみたけど、大して可読性は上がらないな。

要するに、

VLOOKUP($A2,競輪場一覧,COLUMN(Sheet1!B$1),FALSE)

の戻り値が「0」だったら、""を表示せよ、と言っているだけなんだけれど。

ともかく、こんなふうにしておくと、

f:id:akashi_keirin:20171008212745j:plain

「0」が消えて空白セルになった。

んで、差込印刷の結果を見てみる。

f:id:akashi_keirin:20171008212757j:plain

おお、バッチリじゃん!

おわりに

特にVBAの出番もなく解決してしまったけれど、仮にIFERRORのネストを外したとしても結構めんどくさい数式記述が必要なのがイマイチ。もっとスッキリさせたいんだけれど。

@akashi_keirin on Twitter

追記

VLOOKUP関数で空白("")を返す方法

・・・とかなんとか思っていたら、なんと、おなじみOffice TANAKAさんのコチラのページに、

VLOOKUP関数の結果が空欄だったとき、0ではなく空欄を返すようにするには、
=VLOOKUP(D2,A2:B5,2,FALSE)&""
と、末尾に「&""」をつけます。
「&」は文字列を結合する演算子で、空欄である「""」を結合することによって、0を空欄に変換できます。

ですってばよ!

f:id:akashi_keirin:20171008214157j:plain

くそう、

めちゃくちゃカンタンじゃねーかよ!

やっぱり、達人の皆さんはすげえなあ。

差込印刷のデータソースにおけるVLOOKUP関数の使用

差込印刷のデータソースにVLOOKUP関数を使うとちょっと困る

Wordの差込印刷は気が利く

たとえば、Excel

f:id:akashi_keirin:20171008084156j:plain

こんな表を作っておいて、差込印刷のデータソースに指定しておく。

Wordの方では

f:id:akashi_keirin:20171008084204j:plain

こんなふうに差し込みフィールドを設定しておく。

んで、差し込んだ結果を見ると、

f:id:akashi_keirin:20171008084214j:plain

f:id:akashi_keirin:20171008084223j:plain

こんなふうに、データの存在しないところはちゃんとツメてくれる。改段落すらなかったことにしてくれる。

気が利くじゃないか、Word!!!!!!!!!

差し込みデータソースでVLOOKUP関数を使う

今度は、データソース用の表を

f:id:akashi_keirin:20171008084230j:plain

こんなふうにする。

たとえば、B列以降のセルに

=IFERROR(VLOOKUP($A2,Sheet2!$A$1:$H$4,COLUMN(Sheet1!B$1),FALSE),"")

こんな数式を入れておいて、A列の値に応じてB列以降の値を返そうという算段。

VLOOKUP関数の返り値なので、空白だったところには「0」が返っている。

すると、差込印刷の結果は、

f:id:akashi_keirin:20171008084238j:plain

こんな悲しいものになる。なんてこった。

フィールド コードで対応する

対応策をggってみたところ、ヒットしたのが見出しの方法。

差し込みフィールドの場所を右クリックして、

f:id:akashi_keirin:20171008084245j:plain

「フィールド コードの表示/非表示」をクリック。

f:id:akashi_keirin:20171008084252j:plain

たとえばこのようにフィールド コードを書き換える。

「{」、「}」は、

直接入力するんじゃなくて、[Ctrl]+[F9]

なので注意。あと、

[Ctrl]+[F9]を押すときは、半角モードにしておく

のも忘れずに。私は初めてフィールド コードをいじくろうとしたとき、コレでしばらくハマりましたんでw

こうしておくと、差し込み結果は

f:id:akashi_keirin:20171008084302j:plain

こんなふうになる。

困ったことに、改段落をなかったことにはしてくれない。

さてどうするか。続きは次回

@akashi_keirin on Twitter

コチラもどうぞ!

akashi-keirin.hatenablog.com

○箇月後の○曜日――改良版

「○箇月後の○曜日」割り出しFunctionの改良

akashi-keirin.hatenablog.com

VbDayOfWeek型の引数

Twitterのフォロワー氏、及びid:imihito さんが教えてくださった。

vbSundayとかvbMondayって、単なる組み込み定数だと思っていたけれど、正体はVbDayOfWeek列挙体というやつなのですね。

んで、引数の指定の際にVbDayOfWeek型で宣言しておくと、引数入力時にインテリセンスが効くとか。

具体的には、

Public Function hogehoge(ByVal fuga As VbDayOfWeek) As Integer

こんな風に引数を宣言しておくと、

f:id:akashi_keirin:20171007213126j:plain

引数入力時にインテリセンスが働くということ。

こりゃあ便利だ。

自作列挙体型の引数

……ということは、自分で宣言した列挙体でも似たようなことができるのか、と思い、やってみた。

前回のリスト1に出てきたFunction、「calcAnyWeekdayAfterAnyMonths」に引数を一つ追加する。

追加前
Public Function calcAnyWeekdayAfterAnyMonths( _
                  ByVal targetDate As Date, _
                  ByVal months As Integer, _
                  ByVal weekDayAt As Integer) As Date
追加後
Public Function calcAnyWeekdayAfterAnyMonths( _
                  ByVal targetDate As Date, _
                  ByVal months As Integer, _
                  ByVal weekDayAt As VbDayOfWeek, _
                  ByVal mode As ModeSwitch) As Date

第4引数として mode を追加。「ModeSwitch型」という見慣れない型になっているが、これは宣言セクションで

Public Enum ModeSwitch
  modeMostRecent = 0
  modeLast
  modeJustAfter
End Enum

と、このようにModeSwitchという列挙体を宣言してある。

そうすると、引数入力時に

f:id:akashi_keirin:20171007213136j:plain
やはりこのようにインテリセンスが働く。おお! 便利じゃん!

これで、3つのモード、すなわち、

  • ○箇月後の直近の○曜日
  • ○箇月後の直前の○曜日
  • ○箇月後の直後の○曜日

を算出するよう切り替えられるようにすることができる。

DateAdd関数の使用

Twitterのフォロワー氏からのもう一つのご指摘。

1月30日の1箇月後が2月30日、すなわち3月2日になるのではマズい

とのこと。DateAdd関数使やいーじゃん、ということなので、調べてみた。

コチラによると、

構文
DateAdd(Interval,Num,Date)
引数Intervalには、追加する日付や時間の間隔を指定します。
引数Numには、Dateに対して増加させる日付や時間を指定します。
引数Dateには、Numを増加させる元になる日付や時間を指定します。
解説
DateAdd関数は、任意の日付や時間に特定の間隔を追加してその結果を返します。 引数Intervalに指定できる間隔は次のとおりです。
設定値 内容
yyyy
q 四半期
m
y 年間通算日
d
w 週日
ww
h
m
s

とのこと。

例えば、「2017年10月7日の1箇月後の日付」なら、

DateAdd("m", 1, "2017/10/7")

とすれば良い。

Select Case構文の使用

id:imihito さんからのもう一つのご指摘。

あとこちらは私の好みになりますが、calcWeekday 内の処理のように 一つの値の範囲で分岐する処理は Select Caseを使うと見やすくなると思います。
Select Case tgtWeekday - objWeekday
Case Is > 3
calcWeekday = tgtWeekday - objWeekday - 7
Case -3 To 3
calcWeekday = tgtWeekday - objWeekday
Case Is < -3
calcWeekday = tgtWeekday - objWeekday + 7
End Select

ははは。おっしゃる通り。なんでこんな簡単なことに気づかずにうれしそうにIf文を連ねていたんだろ。

あと、「-3≦tgtWeekday - objWeekday≦3」を

Case -3 To 3

と書きゃいいってのも、恥ずかしながら初めて知りました。うん、こりゃ簡単だ。

コードの書き換え

以上のことを踏まえて、コードを書き換えた。

リスト1 標準モジュール
Option Explicit

Public Enum ModeSwitch    '……(1)'
  modeMostRecent = 0
  modeLast
  modeJustAfter
End Enum

Public Function calcAnyWeekdayAfterAnyMonths( _
                  ByVal targetDate As Date, _
                  ByVal months As Integer, _
                  ByVal weekDayAt As VbDayOfWeek, _
                  ByVal mode As ModeSwitch) As Date    '……(2)'
  If weekDayAt < 1 Or weekDayAt > 7 _
    Then Err.Raise 10001, "引数weekDayAtが不正です。"
  If mode < 0 Or mode > 2 _
    Then Err.Raise 10002, "引数modeが不正です。"
  Dim tmpDate As Date
  tmpDate = DateAdd("m", months, targetDate)    '……(3)'
  Dim objWeekday As Integer
  objWeekday = Weekday(tmpDate)
  Dim adjustDateBy As Integer
  adjustDateBy = calcWeekday(mode, weekDayAt, objWeekday)
  calcAnyWeekdayAfterAnyMonths = tmpDate + adjustDateBy
End Function

Public Function hogehoge(ByVal fuga As VbDayOfWeek) As Integer
  hogehoge = fuga
End Function

Private Function calcWeekday(ByVal mode As ModeSwitch, _
                             ByVal tgtWeekday As Integer, _
                             ByVal objWeekday As Integer) As Integer
  If mode < 0 Or mode > 2 _
    Then Err.Raise 10002, "引数modeが不正です。"
  Dim tmp As Integer
  tmp = tgtWeekday - objWeekday
  Select Case mode    '……(4)'
    Case modeMostRecent    '……(5)'
    '直近の○曜日'
      Select Case tmp
        Case Is > 3
          calcWeekday = tmp - 7
        Case -3 To 3
          calcWeekday = tmp
        Case Is < 3
          calcWeekday = tmp + 7
      End Select
    Case modeLast    '……(6)'
    '直前の○曜日'
      If tmp = 0 Then calcWeekday = tmp: Exit Function
      If tmp > 0 Then calcWeekday = tmp - 7: Exit Function
      If tmp < 0 Then calcWeekday = (tmp * -1) - 7: Exit Function
    Case modeJustAfter    '……(7)'
    '直後の○曜日'
      If tmp >= 0 Then calcWeekday = tmp: Exit Function
      If tmp < 0 Then calcWeekday = tmp + 7: Exit Function
  End Select
End Function

(1)からの5行

Public Enum ModeSwitch
  modeMostRecent = 0
  modeLast
  modeJustAfter
End Enum

では、先述の通り、モード切替スイッチ用の引数のために列挙体を宣言。

(2)の

Public Function calcAnyWeekdayAfterAnyMonths( _
                  ByVal targetDate As Date, _
                  ByVal months As Integer, _
                  ByVal weekDayAt As VbDayOfWeek, _
                  ByVal mode As ModeSwitch) As Date

も先述の通り。第3引数weekDayAtをVbDayOfWeek型、第4引数modeをModeSwitch型にしたことで、使用時の引数入力を省力化している。

(3)の

tmpDate = DateAdd("m", months, targetDate)

で、引数targetDateで渡された日付のmonth箇月後の日付を変数tmpに格納。

(4)からの20行

Select Case mode    '……(4)'
  Case modeMostRecent
     ・
     ・
     ・
  Case modeLast
     ・
     ・
     ・
  Case modeJustAfter
     ・
     ・
     ・
End Select

では、まず引数modeの値によって処理を3通りに分岐。それぞれの処理の中身は、まず(5)の

Case modeMostRecent
  '直近の○曜日'
  Select Case tmp
    Case Is > 3
      calcWeekday = tmp - 7
    Case -3 To 3
      calcWeekday = tmp
    Case Is < 3
      calcWeekday = tmp + 7
  End Select

は、直近の○曜日に補正するための計算。変数tmpにはcalcWeekDayプロシージャの入口のところで、「tgtWeekday - objWeekday」を代入している。

(6)の

Case modeLast    '……(6)'
  '直前の○曜日'
  If tmp = 0 Then calcWeekday = tmp: Exit Function
  If tmp > 0 Then calcWeekday = tmp - 7: Exit Function
  If tmp < 0 Then calcWeekday = (tmp * -1) - 7: Exit Function

は、直前の○曜日に補正するための値の算出。

(7)の

Case modeJustAfter    '……(7)'
  '直後の○曜日'
  If tmp >= 0 Then calcWeekday = tmp: Exit Function
  If tmp < 0 Then calcWeekday = tmp + 7: Exit Function

は直後の○曜日に補正するための値の算出。

実行

イミディエイト・ウインドウに次のコードを入力して実験。

まずは、

?calcAnyWeekdayAfterAnyMonths("2017/10/3",2,vbthursday,modeMostRecent)

「2017年10月3日の2箇月後の直近の木曜日」は、

f:id:akashi_keirin:20171007213206j:plain

?calcAnyWeekdayAfterAnyMonths("2017/10/3",2,vbthursday,modeJustAfter)

「2017年10月3日の2箇月後の直後の木曜日」は、

f:id:akashi_keirin:20171007213218j:plain

?calcAnyWeekdayAfterAnyMonths("2017/10/3",2,vbthursday,modeLast)

「2017年10月3日の2箇月後の直前の木曜日」は、

f:id:akashi_keirin:20171007213228j:plain

たぶん、バッチリです。

おわりに

今回は、結構勉強になったなあ。

列挙体型の引数なんて、これから結構使えそうだ。

@akashi_keirin on Twitter

○箇月後の直近の○曜日は?

○箇月後の○曜日の日付を求める自作Function

「1箇月後の直近の木曜日を求める」という作業が発生した。別に、暦を見たらいいんだけれど、もし今後たくさんの日付について同じ作業をする必要が生じたらメンドウなので、ちょこちょこっと「1箇月後の直近の木曜日の日付」を返すFunctionプロシージャを作ってみた。

ただ、「1箇月後の直近の木曜日」にしか対応できないのではツマラナイので、

せめて○箇月後の○曜日ぐらいにはに対応できるようにしておこう

と思い立って、ちょこちょこっと書いてみた。

考え方

VBAには、組み込み定数でvbSunday(正体は"1")~vbSaturday(正体は"7")が定められている。

○箇月後の日付は、元の日付がtargetDateという変数に入っているとすると、

DateSerial(Year(targetDate), Month(targetDate) + ○, Day(targetDate))

で求められる。

で、その返り値(=○箇月後の日付)がtmpDateという変数に入っているとすると、

Weekday(tmpDate)

で曜日を表す整数("1"~"7")が得られる。

あとは、そこから何日ずらせば求めたい曜日にたどり着くかを求め、tmpDateに入っている日付を調整すれば良いだけ。

それぞれの曜日をいくつずらせば求めたい曜日にたどり着くか、というのは規則性のあることなので、一覧表にすれば一般的な計算式が導き出せる。

○箇月後の曜日\目的の曜日 vbSunday(1) vbMonday(2) vbTuesday(3) vbWednesday(4) vbThursday(5) vbFriday(6) vbSaturday(7)
vbSunday(1) +1 +2 +3 -3 -2 -1
vbMonday(2) -1 +1 +2 +3 -3 -2
vbTuesday(3) -2 -1 +1 +2 +3 -3
vbWednesday(4) -3 -2 -1 +1 +2 +3
vbThursday(5) +3 -3 -2 -1 +1 +2
vbFriday(6) +2 +3 -3 -2 -1 +1
vbSaturday(7) +1 +2 +3 -3 -2 -1

とまあ、こんな感じ。

目的の曜日を x 、○箇月後の曜日を y とすると、

  1. x-y>3のとき (x-y)-7
  2. -3≦x-y≦3のとき x-y
  3. x-y<-3のとき (x-y)+7

で、それぞれ目的の曜日にするためにずらす日数が求められる。

コーディング

上記のことを踏まえてコーディングする。

引数は、

  1. 元の日付
  2. 何箇月後か
  3. 直近の何曜日か

の3つ。もちろん、返り値は「○箇月後の○曜日の日付」である。

リスト1 標準モジュール
Option Explicit

Public Function calcAnyWeekdayAfterAnyMonths(ByVal targetDate As Date, _
                                             ByVal months As Integer, _
                                             ByVal weekDayAt As Integer) As Date
  If weekDayAt < 1 Or weekDayAt > 7 _
    Then Err.Raise 10001, "引数weekDayが不正です。"    '……(1)'
  Dim tmpDate As Date
  tmpDate = DateSerial(Year(targetDate), _
                       Month(targetDate) + months, _
                       Day(targetDate))    '……(2)'
  Dim objWeekday As Integer
  objWeekday = Weekday(tmpDate)    '……(3)'
  Dim adjustDateBy As Integer
  adjustDateBy = calcWeekday(weekDayAt, objWeekday)    '……(4)'
  calcAnyWeekdayAfterAnyMonths = tmpDate + adjustDateBy    '……(6)'
End Function

Private Function calcWeekday(ByVal tgtWeekday As Integer, _
                             ByVal objWeekday As Integer) As Integer    '……(5)'
  If (tgtWeekday - objWeekday) > 3 Then calcWeekday = tgtWeekday - objWeekday - 7: Exit Function
  If (tgtWeekday - objWeekday) >= -3 And _
     (tgtWeekday - objWeekday) <= 3 Then calcWeekday = tgtWeekday - objWeekday: Exit Function
  If (tgtWeekday - objWeekday) < -3 Then calcWeekday = tgtWeekday - objWeekday + 7
End Function

(1)の

If weekDayAt < 1 Or weekDayAt > 7 Then Err.Raise 10001, "引数weekDayが不正です。"

では、第3引数を調べ、整数の1~7以外が渡されていたらエラーを吐くようにしている。

(2)の

tmpDate = DateSerial(Year(targetDate), _
                       Month(targetDate) + months, _
                       Day(targetDate))

では、DateSerial関数によって、「months」箇月後の日付を取得。

(3)の

objWeekday = Weekday(tmpDate)

で「months」箇月後の日の曜日を取得。ちなみに、DateSerial関数を使っているので、例えば「1月30日の1箇月後」は、「2月30日」、すなわち平年ならば「3月2日」ということになるので注意。

ここまでで、「months」箇月後の曜日、目的の曜日の2つが判明しているので、(4)の

adjustDateBy = calcWeekday(weekDayAt, objWeekday)

で、これまた自作のcalcWeekday関数に2つの曜日を表す整数を渡して、調整すべき日数を求める。

(5)の

Private Function calcWeekday(ByVal tgtWeekday As Integer, _
                             ByVal objWeekday As Integer) As Integer
  If (tgtWeekday - objWeekday) > 3 Then calcWeekday = tgtWeekday - objWeekday - 7: Exit Function
  If (tgtWeekday - objWeekday) >= -3 And _
     (tgtWeekday - objWeekday) <= 3 Then calcWeekday = tgtWeekday - objWeekday: Exit Function
  If (tgtWeekday - objWeekday) < -3 Then calcWeekday = tgtWeekday - objWeekday + 7
End Function

で調整すべき日数を求める。3つの場合分けで、それぞれ計算方法を分岐。If~ElseIf~Elseで書けるけれど、そうすると読みづらくなるので、ガード節っぽい書き方で3つのIf文を連ねる形にした。

あとは、(6)の

calcAnyWeekdayAfterAnyMonths = tmpDate + adjustDateBy

で日数を調整して、結果を返す。

実行結果

2017年10月3日の1箇月後の直近の木曜日は、

f:id:akashi_keirin:20171003230446j:plain

このとおり。

2017年10月3日の2箇月後の直近の金曜日は、

f:id:akashi_keirin:20171003230453j:plain

このとおり。

2017年10月3日の3箇月後の直近の水曜日は、

f:id:akashi_keirin:20171003230501j:plain

このとおり。

おわりに

まあ、ここまでやったところで、使い道があるかどうかは不明w

車輪の再発明」でないことを祈る。

@akashi_keirin on Twitter

改訂しました

コチラもどうぞ。

akashi-keirin.hatenablog.com

WordドキュメントのPDF化ツール――だいぶ本格的になりました

自作ツール「かんたんPDF変換」

3種類のPDF変換をこなすツールを自作した

akashi-keirin.hatenablog.com

akashi-keirin.hatenablog.com

上記の記事で、Wordドキュメントを編集中にサクッとPDF化するマクロを作ったわけだが、

いっそちゃんとしたツールとして作ってしまおう

と思って、作ってみた。

f:id:akashi_keirin:20171001212117j:plain

実行するとこんなユーザーフォームが出てきて、

  • ドキュメント全体
  • 現在カーソルがあるページのみ
  • 指定したページ範囲

のどれかを選んで実行すると、指定の形でPDFファイルをサクッと吐き出すというもの。

作り方

まず、ユーザーフォームを挿入し、画像のように各コントロールを貼り付ける。

f:id:akashi_keirin:20171001212048j:plain

めんどくさいので、フォーム、各コントロールのサイズや位置に関するプロパティは目分量w

フォーム及び各コントロールのオブジェクト名は画像の通り。

いちおう一覧表にもしておこう。

フォーム・各コントロールのオブジェクト名
フォーム・コントロール オブジェクト名
ユーザーフォーム FrmMain
フレーム FrameMain
オプションボタン OptBtnWhole
オプションボタン OptBtnCurrent
オプションボタン OptBtnSelect
コマンドボタン BtnStart
コマンドボタン BtnCancel
テキストボックス TxtBoxFrom
スピンボタン SpinBtn1
ラベル Label1
テキストボックス TxtBoxTo
スピンボタン SpinBtn1

これだけ準備しておいて、お次はコーディング。

リスト1 フォームモジュール

だいぶ長くなるよ。

Option Explicit
Private currentPage As Integer
Private numOfPagesInDocument As Integer

Private Sub UserForm_Initialize()
  currentPage = Selection.Information(wdActiveEndPageNumber)
  numOfPagesInDocument = Selection.Information(wdNumberOfPagesInDocument)
  With Me
    .OptBtnWhole = True
    Call unablePageSelect
  End With
End Sub

Private Sub unablePageSelect()
  With Me
    .SpinBtn1.Enabled = False
    .SpinBtn2.Enabled = False
    .TxtBoxFrom.Enabled = False
    .TxtBoxTo.Enabled = False
  End With
End Sub

Private Sub BtnCancel_Click()
  Unload Me
End Sub

Private Sub BtnStart_Click()
  With Me
    If .OptBtnWhole.Value _
      Then Call convertDocumentToPDF
    If .OptBtnCurrent.Value _
      Then Call convertActivePageToPDF(currentPage)
    If .OptBtnSelect.Value _
      Then Call convertSelectedPagesToPDF(.TxtBoxFrom.Value, _
                                          .TxtBoxTo.Value)
  End With
  Unload Me
End Sub

Private Sub OptBtnWhole_Change()
  If OptBtnWhole.Value Then Call unablePageSelect
  If OptBtnCurrent.Value Then Call unablePageSelect
End Sub

Private Sub OptBtnCurrent_Change()
  If OptBtnWhole.Value Then Call unablePageSelect
  If OptBtnCurrent.Value Then Call unablePageSelect
End Sub

Private Sub OptBtnSelect_Change()
  If OptBtnWhole.Value Then Call unablePageSelect
  If OptBtnCurrent.Value Then Call unablePageSelect
  If OptBtnSelect.Value Then Call enablePageSelect
End Sub

Private Sub enablePageSelect()
  With Me
    .SpinBtn1.Enabled = True
    .SpinBtn2.Enabled = True
    .TxtBoxFrom.Enabled = True
    .TxtBoxFrom.Value = currentPage
    .TxtBoxTo.Enabled = True
    .TxtBoxTo.Value = numOfPagesInDocument
  End With
End Sub

Private Sub SpinBtn1_SpinDown()
  With Me.TxtBoxFrom
    If CInt(.Value) > 1 Then
      .Value = .Value - 1
    End If
  End With
End Sub

Private Sub SpinBtn1_SpinUp()
  With Me.TxtBoxFrom
    If CInt(.Value) < CInt(Me.TxtBoxTo.Value) Then
      .Value = .Value + 1
    End If
  End With
End Sub

Private Sub SpinBtn2_SpinDown()
  With Me.TxtBoxTo
    If CInt(.Value) > CInt(Me.TxtBoxFrom.Value) Then
      .Value = .Value - 1
    End If
  End With
End Sub

Private Sub SpinBtn2_SpinUp()
  With Me.TxtBoxTo
    If CInt(.Value) < CInt(Selection.Information(wdNumberOfPagesInDocument)) Then
      .Value = .Value + 1
    End If
  End With
End Sub

Private Sub convertDocumentToPDF()
  '///アクティブドキュメントをPDF化する。'
  Dim objDoc As Document
  Set objDoc = ActiveDocument
  Dim pathStr As String
  pathStr = objDoc.FullName
  'フルパスから拡張子の「.」の位置を取得。'
  Dim n As Integer
  n = InStrRev(pathStr, ".")
  '「.」の位置を元に、PDFファイルのフルパスを作る。'
  pathStr = Left(pathStr, n) & "pdf"
  With objDoc
    .ExportAsFixedFormat OutputFileName:=pathStr, _
                         ExportFormat:=wdExportFormatPDF
  End With
  Set objDoc = Nothing
End Sub

Private Sub convertActivePageToPDF(ByVal pageNum As Integer)
  '///アクティブページだけをPDF化する。'
  Dim objDoc As Document
  Set objDoc = ActiveDocument
  Dim pathStr As String
  pathStr = objDoc.FullName
  'フルパスから拡張子の「.」の位置を取得。'
  Dim n As Integer
  n = InStrRev(pathStr, ".")
  '「.」の位置を元に、PDFファイルのフルパスを作る。'
  'ページ番号3ケタゼロ埋め文字列をファイル名に付加する。'
  pathStr = Left(pathStr, n - 1) & _
            "_P." & Format(pageNum, "00#") & ".pdf"
  With objDoc
    .ExportAsFixedFormat OutputFileName:=pathStr, _
                         ExportFormat:=wdExportFormatPDF, _
                         Range:=wdExportCurrentPage
  End With
  Set objDoc = Nothing
End Sub

Private Sub convertSelectedPagesToPDF(ByVal pageFrom As Integer, _
                                      ByVal pageTo As Integer)
  '///指定されたページ範囲をPDF化する。'
  Dim objDoc As Document
  Set objDoc = ActiveDocument
  Dim pathStr As String
  pathStr = objDoc.FullName
  'フルパスから拡張子の「.」の位置を取得。'
  Dim n As Integer
  n = InStrRev(pathStr, ".")
  '「.」の位置を元に、PDFファイルのフルパスを作る。'
  'ページ番号3ケタゼロ埋め文字列をファイル名に付加する。'
  pathStr = Left(pathStr, n - 1) & _
            "_P." & Format(pageFrom, "00#") & _
            "-P." & Format(pageTo, "00#") & ".pdf"
  With objDoc
    .ExportAsFixedFormat OutputFileName:=pathStr, _
                         ExportFormat:=wdExportFormatPDF, _
                         Range:=wdExportFromTo, _
                         From:=pageFrom, _
                         To:=pageTo
  End With
  Set objDoc = Nothing
End Sub

実行

エントリーポイントとして、標準モジュールに次のコードを書く。

スト2 標準モジュール
Public Sub run()
  FrmMain.Show
End Sub

このマクロを書いたファイルを「.dotm」形式で

ユーザー\AppData\Roaming\Microsoft\Word\STARTUP フォルダ

に保存、クイック アクセス ツール バー に登録して実行するようにする。

一連の方法は

akashi-keirin.hatenablog.com

コチラをどうぞ。

f:id:akashi_keirin:20171001212213j:plain

こんなドキュメントがあったとして、

f:id:akashi_keirin:20171001212226j:plain

こんなふうに条件を指定して[PDF化]ボタンをクリックすると、

f:id:akashi_keirin:20171001212242j:plain

f:id:akashi_keirin:20171001212253j:plain

一瞬でPDF化できた。

おわりに

なかなか便利なツールに仕上がったんではないでしょうか。

え? 「飛び飛びのページを指定してPDF化したいときはどうするんだよ!?」ですか?

そんなもん、不要なページを削除してからPDF化して、ドキュメントを保存せずに閉じたらいいじゃねーかよ!!!!!!!!

はっ、取り乱しました。

まあ、とりあえず動くこと優先で書き飛ばしたコードなのでムダが多いコードだとは自分でも思いますよ。まあ、ヒマなときにリファクタリングするので、そのときはまたネタにしようかな。

ヒマな人はリファクタリングの練習用にどうぞ。

@akashi_keirin on Twitter