Len関数の返り値
Len関数の返り値
Len関数に文字列ではなく数値を渡してしまい、意図しない値が返っていたために小ハマりしてしまったので、反省も込めて覚え書き的に記しておく。
Len関数に数値を渡すとどうなるか
たとえば、次のようなコードの場合。
Dim hoge As Long hoge = -1 Debug.Print Len(hoge)
通常、こんなアホなコードを書くことはないと思うが、初心者だと
Len関数 = 文字数を返す
という強固な思い込みがあるので、下手をすると
Len(hoge)
が、
2を返す
とか考えてしまわないだろうか。
全然違うのである。
Microsoft Office デベロッパー センター より
Microsoft Office デベロッパー センターの「Len関数」の項によると、
文字列の文字数、または変数の格納に必要なバイト数を含む長整数型 (Long) を返します。
Microsoft Office デベロッパー センターの「Len関数」の項より※強調は引用者。
つまり、文字列を渡した場合なら素直に文字数を返してくれるが、文字列以外を渡してしまったら、「変数の格納に必要なバイト数」が返ってしまうのである。
したがって、上掲コードの場合、変数hogeはLong型ゆえに、Len(hoge)は4を返すことになる。
実験
上記のことを示すためにちょいと実験。
リスト１ 標準モジュール
Private Sub test() Dim a As Integer, b As Long, c As Currency a = -1 b = a c = a Dim d As String d = CStr(a) Debug.Print Len(a); Len(b); Len(c); Len(d) End Sub
変数aはInteger型、bはLong型、cはCurrency型にして、全てに-1を代入。変数dはString型にし、-1をString型にキャストした上で代入した。
実行結果
イミディエイト・ウインドウの出力は、
ご覧のとおり。
おわりに
「だから何？」とか言われましても……。
Worksheet.PageSetup.FitToPagesTall/Wideの設定はリアルタイムで反映されない
[Worksheet].PageSetup.FitToPagesTall/Wideの設定はリアルタイムで反映されない
知ってました？
私はこのことに気づかなかったせいで、お盆の期間だというのにドハマりして残業してしまいました。
状況
次のようなシートがあるとする。
四隅のち～んｗを一枚のシートに収めたいのだが、ご覧のようにでたらめなところに改ページが入ってしまっている。
そこで、次のコードで一枚のシートに収めようと試みた。
リスト１ 標準モジュール
Option Explicit
Private Sub testFitToOnePage()
Dim Sh As Worksheet
Set Sh = ActiveSheet
With Sh.PageSetup
.Zoom = False
.FitToPagesTall = 1
.FitToPagesWide = 1
End With
End Sub
しかし、こいつを何度実行しても、シートの見た目は
このとおり、微動だにしない。
だから、てっきりこのやり方ではだめなのだと思っていた。
しかし、[ファイル]メニューから印刷プレビューをのぞきに行くと、
なんと、ちゃんと１ページに収まっているではないか！
要するに、処理の結果が編集画面に反映されていないだけだったのだ。
くそー。何だったんだよ！
おわりに
[Worksheet].PageSetup.FitToPagesTall及び同FitToPagesWideプロパティ設定をしても、すぐに見た目には反映されず、プレビューなどを表示させた後でシートに戻ると反映されています。
ちなみに、リスト１を
Private Sub testFitToOnePage()
Dim Sh As Worksheet
Set Sh = ActiveSheet
With Sh.PageSetup
.Zoom = False
.FitToPagesTall = 3
.FitToPagesWide = 4
End With
Call Sh.PrintPreview
End Sub
とかにして実行しても、
こうなるだけです。決して３×４に均等に分割してくれるわけではありません。
一応、「次のページ数に合わせて印刷」のところは「４×３」とかになっていますが。
参考
改ページまわりについてはコチラもどうぞ。
Boolean型Function作成時のコーディング規約
Boolean型Function作成時のコーディング規約
Forループで回すときなんかに、そもそも処理をすべきなのかどうかを判定し、処理の必要がなければ飛ばす、ということがよくある。
処理の要不要を判定する条件が単純なら、ブロック内でIf分岐すればよいが、判定条件がそこそこややこしくなってくると、判定処理そのものをメソッドとして括り出したくなる。
そういうときのコードの書き方について述べる。
条件に引っかかったら即return
現在のところ、私の方針は見出しのとおり。
たとえば、条件が(1)～(5)まであるとして、一つでも引っかかったらFalseというisHogeというBoolean型メソッドを考える。
私は、次のように書くようにしている。
リスト１
Private Function isHoge(Byval arg As String) As Boolean isHoge = False If 条件(1) Then Exit Function If 条件(2) Then Exit Function If 条件(3) Then Exit Function If 条件(4) Then Exit Function If 条件(5) Then Exit Function isHoge = True End Function
こんな感じ。
条件判定のところは、Orを使って書くこともできるが、一つでも引っかかったら即returnすればいいので、1行1行書いておいたほうが後で読みやすいと思う。
おわりに
メソッド名を変えたときに、二箇所修正しないといけないのが難点といえば難点。
しかし、返り値用変数retを使うやり方だと、即returnのたびにretを書かなくてはいけなくなるので却ってめんどくさい。メソッド名は必ず冒頭と最後に出てくるので、修正漏れリスクも極小だと思う。
コーディングの作法については、人それぞれに色んな考えがあるので、色々な理屈に触れてみたい。
foobar2000の楽曲再生データを編集するためのモジュール
foobar2000の楽曲データをいじくるためのモジュール
作ったので公開。
コード
foobar2000のPlaybackStatisticsでエクスポートできるXMLをいじくるためのメソッド集的なモジュールを作成した。
一挙公開する。（2019/9/16更新）
リスト１ 標準モジュールFB2KUtil
Option Explicit 'Constants' '2012年1月1日 0時00分00秒の日付時刻値の上11桁' Private Const STANDARD_DATE_VALUE As Currency = 12969817200# Private Const STANDARD_DATE As Date = #1/1/2012# '一日あたりの秒数' Private Const DAY_BY_SECONDS As Currency = 86400 Private Const HOUR_BY_SECONDS As Currency = 3600 Private Const MINUTE_BY_SECONDS As Currency = 60 '///XMLファイルの中身を作る' Public Function createXMLContents( _ ByVal contents As String) As String Const XML_DECLARATION As String = _ "" & _ vbCrLf Dim ret As String If Not (Right(contents, 2) = vbCrLf) Then _ contents = contents & vbCrLf ret = XML_DECLARATION ret = ret & contents ret = ret & " " createXMLContents = ret End Function '///データを連結してXML要素を作る' Public Function getXMLElement( _ ByVal targetID As String, _ ByVal count As Long, _ ByVal fpDate As Date, _ ByVal fpTime As Date, _ ByVal lpDate As Date, _ ByVal lpTime As Date, _ ByVal aDate As Date, _ ByVal aTime As Date, _ ByVal rating As Long) As String Dim idStr As String idStr = vbTab & "" getXMLElement = idStr & countStr & fpStr & lpStr & aStr & ratingStr End Function '///FB2Kの楽曲データからID値を取得する' Public Function getID( _ ByVal targetElement As String) As String Const ADD_COUNT As Long = 11 '最初の「<」の11字後ろがIDの先頭' Const ID_LENGTH As Long = 16 'ID値は16文字' Dim ret As String Dim startPos As Long startPos = InStr(1, targetElement, "<") + ADD_COUNT ret = Mid(targetElement, startPos, ID_LENGTH) getID = ret End Function '///FB2Kの楽曲データからFirstPlayedのDate型データを取得する' Public Function getFirstPlayDateTime( _ ByVal targetElement As String) As Date Dim ret As Date ret = 0 Dim targetSerial As Currency targetSerial = getFirstPlayedSerial(targetElement) 'FirstPlayedの値がないときは、0が返る' If targetSerial = 0 Then GoTo Finalizer ret = getDateTime(targetSerial) Finalizer: getFirstPlayDateTime = ret End Function '///FB2Kの楽曲データからLastPlayedのDate型データを取得する' Public Function getLastPlayDateTime( _ ByVal targetElement As String) As Date Dim ret As Date ret = 0 Dim targetSerial As Currency targetSerial = getLastPlayedSerial(targetElement) 'LastPlayedの値がないときは、0が返る' If targetSerial = 0 Then GoTo Finalizer ret = getDateTime(targetSerial) Finalizer: getLastPlayDateTime = ret End Function Public Function getAddedDateTime( _ ByVal targetElement As String) As Date Dim ret As Date ret = 0 Dim targetSerial As Currency targetSerial = getAddedSerial(targetElement) 'Addedの値がないときは、0が返る' If targetSerial = 0 Then GoTo Finalizer ret = getDateTime(targetSerial) Finalizer: getAddedDateTime = ret End Function '///日付時刻値を求める' Private Function getDateTimeValue( _ ByVal targetDate As Date, _ ByVal targetTime As Date) As String Const HOUR_TO_SECONDS As Currency = 3600 Const MINUTE_TO_SECONDS As Currency = 60 Dim ret As Currency '基準日との日数差を計算する' Dim dateDiff As Currency dateDiff = DateSerial(Year(targetDate), Month(targetDate), Day(targetDate)) - _ DateSerial(Year(STANDARD_DATE), Month(STANDARD_DATE), Day(STANDARD_DATE)) '日数差を秒に換算する' dateDiff = dateDiff * DAY_BY_SECONDS '基準日の値に加算する' ret = STANDARD_DATE_VALUE + dateDiff '時間を秒に換算して値に加算する' Dim timeValue As Currency timeValue = Hour(targetTime) * HOUR_TO_SECONDS + _ Minute(targetTime) * MINUTE_TO_SECONDS + _ Second(targetTime) ret = ret + timeValue '文字列に変換して下7桁を0で埋める' getDateTimeValue = CStr(ret) & "0000000" End Function '///FB2Kの楽曲データからFirstPlayedのシリアル値を取得する' Private Function getFirstPlayedSerial( _ ByVal targetElement As String) As Currency Dim ret As Currency ret = getDateTimeSerial(targetElement, "FirstPlayed=""") getFirstPlayedSerial = ret End Function '///FB2Kの楽曲データからLastPlayedのシリアル値を取得する' Private Function getLastPlayedSerial( _ ByVal targetElement As String) As Currency Dim ret As Currency ret = getDateTimeSerial(targetElement, "LastPlayed=""") getLastPlayedSerial = ret End Function '///FB2Kの楽曲データからAddedのシリアル値を取得する' Private Function getAddedSerial( _ ByVal targetElement As String) As Currency Dim ret As Currency ret = getDateTimeSerial(targetElement, "Added=""") getAddedSerial = ret End Function '///日付時刻を表すFB2K独自のシリアル値（の上11ケタ）を返す' ' 【例】FirstPlayedのシリアル値を取得したいときは、引数keyWordに' ' "FirstPlayed="""を指定する。' Private Function getDateTimeSerial( _ ByVal targetElement As String, _ ByVal keyWord As String) As Currency 'シリアル値18文字中上11ケタを返す' Const NUMBER_OF_DIGITS As Long = 11 Dim ret As Currency Dim pos As Long pos = InStr(1, targetElement, keyWord) If pos = 0 Then ret = 0: GoTo Finalizer 'シリアル値開始位置を割り出す。LastPlayedなら、' '「LastPlayed="」の開始位置に「LastPlayed="」の文字数を足せばよい。' pos = pos + Len(keyWord) ret = CCur(Mid(targetElement, pos, NUMBER_OF_DIGITS)) Finalizer: getDateTimeSerial = ret End Function '///FB2Kの日付時刻コードを、Date型に変換する' Private Function getDateTime( _ ByVal datetimeSerial As Currency) As Date Dim ret As Date '日付時刻コードの上11ケタを取得' datetimeSerial = Left(datetimeSerial, 11) '基準日（2012/1/1）との差分(FB2K独自のシリアル値)を取得' Dim serialDiff As Currency serialDiff = datetimeSerial - STANDARD_DATE_VALUE '基準日に加算する日数を取得' Dim addDay As Currency addDay = serialDiff \ DAY_BY_SECONDS '加算日数を加算' ret = STANDARD_DATE + addDay '加算する時間を取得' Dim addHour As Long Dim tmp As Long tmp = serialDiff Mod DAY_BY_SECONDS addHour = tmp \ HOUR_BY_SECONDS '加算する分を取得' Dim addMinute As Long tmp = tmp Mod HOUR_BY_SECONDS addMinute = tmp \ MINUTE_BY_SECONDS '加算する秒を取得' Dim addSecond As Long addSecond = tmp Mod MINUTE_BY_SECONDS '時刻を追加' ret = ret + TimeSerial(addHour, addMinute, addSecond) getDateTime = ret End Function '///FB2Kの楽曲データからCountの値を取得する' Public Function getCount( _ ByVal targetElement As String) As Long Dim ret As Long ret = 0 ret = CLng(getQuortedValue(targetElement, "Count=""")) getCount = ret End Function '///FB2Kの楽曲データからRatingの値を取得する' Public Function getRating( _ ByVal targetElement As String) As Long Dim ret As Long 'Rating文字列を取得' ret = CLng(getQuortedValue(targetElement, "Rating=""")) '数値（0～5）に変換' ret = getRatingValue(CStr(ret)) getRating = ret End Function '///ダブルクォーテーションで囲まれた値を文字列として取り出す' ' 【例】Count="12" から「12」を取り出したいときは、引数KeyWordに' ' "Count="""を渡す。' Private Function getQuortedValue( _ ByVal targetElement As String, _ ByVal keyWord As String) As String Dim ret As String ret = "" 'keyWordがtargetElement内になければ「0」を返す' Dim n As Long n = InStr(1, targetElement, keyWord) If n = 0 Then ret = "0": GoTo Finalizer 'keyWordの次の文字から１文字づつ、次の「"」にぶつかるまで連結' n = n + Len(keyWord) Do ret = ret & Mid(targetElement, n, 1) n = n + 1 Loop Until Mid(targetElement, n, 1) = """" Finalizer: getQuortedValue = ret End Function '///Ratingの値を固有の文字に置き換える' Private Function getRatingCode( _ ByVal rating As Long) As String Dim ret As String Select Case rating Case 0: ret = "0" Case 1: ret = "63" Case 2: ret = "106" Case 3: ret = "149" Case 4: ret = "191" Case 5: ret = "234" Case Else: ret = "0" End Select getRatingCode = ret End Function '///Ratingの固有文字を数値に置き換える' Private Function getRatingValue( _ ByVal ratingCode As String) As Long Dim ret As Long ret = 0 Select Case ratingCode Case "0": ret = 0 Case "63": ret = 1 Case "106": ret = 2 Case "149": ret = 3 Case "191": ret = 4 Case "234": ret = 5 End Select getRatingValue = ret End Function
とりあえず、めんどくさいので説明の類は省略。
上記メソッドをうまく使えば、foobar2000の再生データをほぼ自由自在に書き換えることができる。
使用例
現在のところ、私はExcelのワークシートで
このような表を作り、Ａ列の「XML Element」欄にPlayback StatisticsでエクスポートしたXMLの要素を貼り付けておき、マクロでＢ列以降に一旦データを出力。編集して再度XMLファイル化し、foobar2000にインポート、という手順で楽曲の再生データを編集している。
動作の様子は
こんな感じ。
ちなみに、foobar2000上では
こんな感じです。
おわりに
あまり需要はなさそうですね。寂しいなあ。
抽籤マクロ(Excel)
順番の抽籤をする
研修会とかそういう機会に、発表の順序を決めるとき。
自薦方式をとったり、じゃんけんで決めてもらったりするのも良いが、Excelでやってみてもいいんではないか、と思った。
準備
次のようなシートを準備。
「抽籤！」ボタンをクリックすると、セルに発表グループ名（今回は番号）が表示されるようにする。
仕様
ただ発表順がいっぺんに表示されるだけだと盛り上がらないので（別に盛り上げる必要はないんだが。）、
- 正式表示まで番号がグルグル表示されるようにする
- 一つづつ、それなりに間を空けて表示されるようにする
- 終わったら「決定！」と表示するようにする
と、こんな感じにした。
抽籤マクロのコード
シートモジュールにメインのコードを書くことにし、乱数発生のためのモジュール（自作のRandUtilモジュール）と、WindowsAPI関数呼び出し用のクラス（自作のWinAPIクラス）をインポートして使用した。
リスト１ 標準モジュールRandUtil
Option Explicit
Public Function getRandomOrder( _
ByVal maxNumber As Long, _
Optional ByVal allowDuplicate As Boolean = False) As Long()
'///1～maxNumまでの整数をランダムに並べて配列に格納する。'
'///引数maxNum：最大数'
'///引数allowDuplicate：重複を許可するならTrue'
Dim ret() As Long
Dim hasSet() As Boolean
ReDim hasSet(maxNumber - 1)
Dim i As Long
ReDim ret(maxNumber - 1)
Randomize
Dim tmp As Long
For i = 0 To maxNumber - 1
Do
tmp = Int(maxNumber * Rnd + 1)
'///乱数：Int((最大値 - 最小値 + 1) * Rnd + 最小値)'
Loop Until hasSet(tmp - 1) = False
ret(i) = tmp
If Not allowDuplicate Then hasSet(tmp - 1) = True
Next
getRandomOrder = ret
End Function
リスト２ クラスモジュールWindowsAPI
※必要な部分のみ。
Option Explicit '///Attribute VB_PredeclaredId = True////' 'WindowsAPI Functions' Private Declare Function GetTickCount Lib "kernel32" () As Long Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'Methods' Public Function callGetTickCount() As Long Dim ret As Variant ret = GetTickCount() ret = CDec(ret) If ret < 0 Then ret = ret + 2 ^ 32 callGetTickCount = ret End Function Public Sub callSleep(ByVal milliSeconds As Long) Call Sleep(milliSeconds) End Sub Public Sub waitFor(ByVal milliSeconds As Long) Dim startTime As Long startTime = callGetTickCount() Dim endTime As Long Do Call Sleep(1) DoEvents endTime = callGetTickCount() Loop Until endTime - startTime > milliSeconds End Sub
リスト３ シートモジュールSh01Main
Option Explicit Private Const AREA_ADDRESS As String = "$A$2:$F$2" Private Enum Sh01ErrorCode sh01ecUnknown sh01ecIncorrectArg End Enum Public Property Get DisplayArea( _ Optional ByVal indexOf As Long) As Range Const ERR_SOURCE As String = _ "Sh01Main Property Get DisplayArea" '引数indexOfを省略したら範囲全体を返す' Dim ret As Range Set ret = Me.Range(AREA_ADDRESS) If indexOf = 0 Then GoTo Finalizer 'ガード節：不正引数を弾く' If indexOf > ret.Columns.Count Then _ Call raiseError(sh01ecIncorrectArg, ERR_SOURCE) '引数indexOfに応じたセルを返す' Set ret = ret.Cells(1, indexOf) Finalizer: Set DisplayArea = ret End Property Private Sub setNumber() 'グルグル表示のリピート回数' Const REPEAT_COUNT As Long = 8 'グルグル表示のインターバル' Const DISPLAY_INTERVAL As Long = 50 '抽選結果表示のインターバル' Const SHOW_INTERVAL As Long = 1000 Dim targetArea As Range Set targetArea = Me.DisplayArea '一旦表示をクリア' Call targetArea.ClearContents Dim maxNumber As Long maxNumber = targetArea.Columns.Count - 1 '乱数配列を取得' Dim order() As Long order = RandUtil.getRandomOrder(maxNumber, False) 'WinAPIクラスをインスタンス化' Set winAPI = New WindowsAPI Dim i As Long Dim j As Long For i = LBound(order) To UBound(order) With Me.DisplayArea(i + 1) 'グルグル表示' For j = 0 To (maxNumber * REPEAT_COUNT) - 1 '0.1秒ごとに数字を表示' .Value = order(j Mod maxNumber) Call winAPI.waitFor(DISPLAY_INTERVAL) Next '結果表示' .Value = order(i) '少し間を空ける' Call winAPI.waitFor(SHOW_INTERVAL) End With Next '「決定！」表示' Me.DisplayArea(maxNumber + 1).Value = "決定！" End Sub Private Sub raiseError(ByVal errCode As Sh01ErrorCode, _ ByVal errSource As String) Dim msg As String Select Case errCode Case sh01ecIncorrectArg ret = "The arg ""indexOf"" is out of bound." Case Else ret = "Some error has occurred!" End Select Call Err.Raise(Number:=10000 + errCode, _ Source:=errSource, _ Description:=ret) End Sub
例によって、現時点では特に必要でもないエラー対応なんかを入れたせいでタテ長になっている。
必要な箇所にはコメントを入れているので、細かい説明は省略。
実行
シート上のコマンドボタンにSh01MainモジュールのsetNumberメソッドを登録して実行。
ご覧のとおり。
おわりに
身内向けの研修会なんかだと、この程度のギミックを披露するだけで歓声が上がるのだから、チョロいもんですｗ（実際、今回のギミックは、昼休みの10分ぐらいでサクッと作ったもの。）
WindowsAPI関数をもっとふんだんに使用して、グルグル表示中にドラムロールを鳴らしたりしたら、もっとウケるだろうな……。当面やるつもりはないけど。
あと、美しさを求めるなら、ユーザーフォームでしょうね。
参考
コチラもどうぞ！
語順整序英作文問題を作成するマクロ
おれならこう書く（余計なお世話）
Twitterを眺めていたら、
こういうものを発見。
面白そうなので、〈おれならこう書く〉ってのをやってみようかな、と。
元記事の筆者さんにとっては、完全に
余計なお世話
だと思いますが、見逃してください。
元々のコード
元記事から引用する。
「英文並べ替え問題を自動で作成するExcel VBAプログラム」Dim nowRow As Integer 'プロシージャをまたいで使うのでまず宣言 Sub 総合() MaxRow = ThisWorkbook.Worksheets(1).Range("B1").End(xlDown).Row '「原文」列が何行あるか数える For nowRow = 2 To MaxRow 'その行数分、並び替えを続ける Call この1列 Next Range("A1").Select 'なんとなくカーソルをA1に戻す End Sub Sub この1列() Target = Cells(nowRow, 2).Value '原文取得 LastT = Right(Target, 1) '最後の1文字（"."か"?"）をとっておく Target = Left(Target, Len(Target) - 1) 'ひとまず最後の1文字を消す ChaN = Len(Target) - Len(Replace(Target, " ", "")) + 1 'スペースの数＋1が単語数（ChaN） splTarget = Split(Target, " ") '空白で区切って配列に格納 For n = 2 To ChaN + 1 '2行目から[単語数＋1]行目までFor Cells(n, 7) = splTarget(n - 2) 'G列に1語ずつ入れる Cells(n, 8) = Rnd 'H列に並べ替え用の乱数を入れる Next Range(Cells(2, 7), Cells(ChaN + 1, 8)) _ .Sort Key1:=Range("H2"), order1:=xlAscending 'G:HをH列で並べ替え narabekae = "( " 'D列に入れる文字列を作成開始（narabekae） For n = 2 To ChaN + 1 narabekae = narabekae & Cells(n, 7).Value & " / " 'G列上から入れ、" / "で区切る Next narabekae = narabekae & ")" & LastT '最後は括弧で閉じて"."か"?"を末尾に足す narabekae = Replace(narabekae, " / )", " )") '最後の一語の処理 narabekae = Replace(narabekae, "+", " ") '一緒になっていた語をバラバラに Cells(nowRow, 4).Value = narabekae '完成したものをD列に入れる Range("G2:H100").Clear '計算用の列は削除 'C列に正解の文章を入れる Seikai = Cells(nowRow, 2).Value 'もう一度原文を取得 Seikai = Replace(Seikai, "+", " ") '"+"を" "に置換 First = StrConv(Left(Seikai, 1), vbUpperCase) '最初の一文字を切り出し、大文字に Seikai = First & Mid(Seikai, 2, 100) '大文字にした1文字目と、そのままの2文字目以下を合体 Cells(nowRow, 3).Value = Seikai '完成したものをC列に入れる End Sub
こんな感じ。
次のように
同じようなワークシートを作って、やってみよう。
作成したコード
……意外とヒマかかった……。
めんどくさいので、ひとまず作成したコードだけ上げとこう。
プロジェクトの構成
シートモジュール Sh01Main
〈シートの機能〉的側面が強いので、シートモジュールに書いた。「Sh01Main」というのは自分でつけたオブジェクト名です。
標準モジュール EngUtil
英文を加工する処理は、今後も使うことがあるかも知れないので、標準モジュールに書いた。当然「EngUtil」というのも自分でつけたオブジェクト名です。
では、実際のコードをどうぞ。
リスト１ シートモジュールSh01Main
Option Explicit 'Constants' Private Enum Sh01ShiftSize sh01ssNumber sh01ssMaterial sh01ssFinished sh01ssSeparated End Enum 'Properties' 'シートの表の部分を返す' Friend Property Get MainTable() As Range Dim rng As Range Set rng = Nothing Set rng = Me.Range("A1").CurrentRegion If rng.Rows.Count < 2 Then GoTo Finalizer With rng Set rng = .Offset(1, 0) Set rng = rng.Resize(.Rows.Count - 1, .Columns.Count) End With Finalizer: Set MainTable = rng End Property 'Methods' Private Sub createQuestions() Dim rng As Range Set rng = Me.MainTable If rng Is Nothing Then Exit Sub Dim i As Long Dim targetCell As Range With rng For i = 1 To .Rows.Count Set targetCell = .Cells(i, 1) '完成品、並べ替え問題を出力するセルの内容をクリア' Call clearContentsBeforeRun(targetCell) '並べ替え素材のあるセルを取得' Dim materialCell As Range Set materialCell = targetCell.Offset(0, sh01ssMaterial) '完成品を出力するセルを取得' Dim finishedCell As Range Set finishedCell = targetCell.Offset(0, sh01ssFinished) '英文の完成品を出力' finishedCell.Value = getArrangedSentence(materialCell.Value) '並べ替え問題を出力するセルを取得' Dim separatedCell As Range Set separatedCell = targetCell.Offset(0, sh01ssSeparated) separatedCell.Value = getRandomizedSentence(materialCell.Value) Next End With End Sub '完成品、並べ替え問題を出力するセルの内容をクリアする' Private Sub clearContentsBeforeRun( _ ByVal targetCell As Range) Dim i As Long With targetCell For i = sh01ssFinished To sh01ssSeparated .Offset(0, i).Value = "" Next End With End Sub 'B列の素材を元に完成品を作成する' Private Function getArrangedSentence( _ ByVal material As String) As String Dim ret As String '「+」記号を半角スペースに置き換える' ret = Replace(material, "+", " ") Dim ar() As String ar = Split(ret) '先頭の単語だけ先頭大文字に' ar(0) = StrConv(ar(0), vbProperCase) 'つなぎ直す' ret = Join(ar) getArrangedSentence = ret End Function '並べ替え問題を作る' Private Function getRandomizedSentence( _ ByVal material) As String Dim ret As String Dim ar() As String ar = EngUtil.getRandomizedWords(material) ret = "( " Dim i As Long For i = LBound(ar) To UBound(ar) - 1 '「+」記号は半角スペースにする' ar(i) = Replace(ar(i), "+", " ") '最後は区切りのスラッシュは要らない' If i = UBound(ar) - 1 Then ret = ret & ar(i) Else ret = ret & ar(i) & " / " End If Next '文末記号を追加' ret = ret & ") " & ar(UBound(ar)) getRandomizedSentence = ret End Function
タテ長になってすまない。
コメントを入れまくっているから、説明は省略。
かなり細かくプロシージャを分割した。
リスト２ 標準モジュールEngUtil
Option Explicit Private Enum ErrorCode ecUnknown ecNotSingle = 1 End Enum '英文の加工に関するメソッドを集めたモジュール' '単語をランダムに並べ替えた配列を返す' Public Function getRandomizedWords( _ ByVal targetSentence As String) As String() Const ERR_SOURCE As String = "EngUtil.getRandomizedWords Method" Dim ret() As String Dim wordTerminator As String wordTerminator = Right(targetSentence, 1) '右端の文字が文末記号でなかったら、文末記号を加える' If Not isTerminator(wordTerminator) Then _ wordTerminator = ".": _ targetSentence = targetSentence & wordTerminator 'とりあえずピリオド' 'いったん文末記号を除いた文字列を取得' Dim tmpString As String tmpString = Left(targetSentence, Len(targetSentence) - 1) 'いったん配列化' Dim ar() As String ar = Split(tmpString) '要素数を取得' Dim wordsCount As Long wordsCount = UBound(ar) + 1 '返す配列の要素数を取得(配列は0始まりなのでピリオド等を除いた' '単語数=ピリオドを含めた配列の添字最大値になる)' ReDim ret(wordsCount) 'ランダム並べ替え用の配列を準備' Dim randOrder() As Long randOrder = getRandomOrder(wordsCount) '単語を並べ替えて配列にセット' Dim i As Long For i = LBound(ar) To UBound(ar) ret(i) = ar(randOrder(i) - 1) Next 'この時点で、配列retの最終要素以外に全単語が収まっている' 'retの最終要素に文末記号を入れる' ret(wordsCount) = wordTerminator '配列をreturn' getRandomizedWords = ret End Function Private Function isTerminator( _ ByVal targetChar As String) As Boolean Const ERR_SOURCE As String = "EngUtil.isTerminator Method" Const WORD_TERMINATORS As String = ". ! ?" If Len(targetChar) <> 1 Then Call raiseError(ecNotSingle, _ ERR_SOURCE) isTerminator = True Dim ar() As String ar = Split(WORD_TERMINATORS) Dim i As Long For i = LBound(ar) To UBound(ar) If targetChar = ar(i) Then Exit Function Next isTerminator = False End Function Private Function getRandomOrder( _ ByVal maxNumber As Long, _ Optional ByVal allowDuplicate As Boolean = False) As Long() '///1～maxNumまでの整数をランダムに並べて配列に格納する。' '///引数maxNum：最大数' '///引数allowDuplicate：重複を許可するならTrue' Dim ret() As Long Dim hasSet() As Boolean ReDim hasSet(maxNumber - 1) Dim i As Long ReDim ret(maxNumber - 1) Randomize Dim tmp As Long For i = 0 To maxNumber - 1 Do tmp = Int(maxNumber * Rnd + 1) '///乱数：Int((最大値 - 最小値 + 1) * Rnd + 最小値)' Loop Until hasSet(tmp - 1) = False ret(i) = tmp If Not allowDuplicate Then hasSet(tmp - 1) = True Next getRandomOrder = ret End Function Private Sub raiseError(ByVal errType As ErrorCode, _ ByVal errSource As String) Dim errMsg As String Select Case errType Case ecUnnown: errMsg = "Some error has occurred!" Case ecNotSingle: errMsg = "Arg is not a single-character!" Case Else: errMsg = "Some error has occurred!": errType = ecUnknown End Select Call Err.Raise(Number:=10000 + errType, _ Source:=errSource, _ Description:=errMsg) End Sub
当面必要なさそうなエラー対応まで入れているのでタテ長になってしまっているが、getRandomizedWordsのところだけ見てもらえれば。
シートモジュールに書いたcreateQuestionsメソッドから呼び出している。
実行
シート状にコマンドボタンを置き、createQuestionsメソッドを登録して実行してみる。
バッチリ。
おわりに
本当は、元のコードと比較対照しながらまとめたかったんですけど、めんどくさくてこんな形になってしまいました。
ランダム座席表マクロ
ランダム席替えマクロ
作ってみた。
座席表の枠を作ったシートの機能なので、シートモジュールに生やしてみた。
準備
ランダムに並べるために、乱数発生用のメソッドを用意する。
今回は、標準モジュールにRandUtilと名前を付け、RandUtilモジュールのメソッド、という形にした。
リスト１ 標準モジュールRandUtil
Public Function getRandomOrder( _
ByVal maxNumber As Long, _
Optional ByVal allowDuplicate As Boolean = False) As Long()
'///1～maxNumまでの整数をランダムに並べて配列に格納する。'
'///引数maxNum：最大数'
'///引数allowDuplicate：重複を許可するならTrue'
Dim ret() As Long
Dim hasSet() As Boolean
ReDim hasSet(maxNumber - 1)
Dim i As Long
ReDim ret(maxNumber - 1)
Randomize
Dim tmp As Long
For i = 0 To maxNumber - 1
Do
tmp = Int(maxNumber * Rnd + 1)
'///乱数：Int((最大値 - 最小値 + 1) * Rnd + 最小値)'
Loop Until hasSet(tmp - 1) = False
ret(i) = tmp
If Not allowDuplicate Then hasSet(tmp - 1) = True
Next
getRandomOrder = ret
End Function
数字をランダムに並べ替えて配列にして返すメソッド。
重複回避のためにBoolean型配列を使うやり方は、たぶん昔
で見つけたのだった。
既に使われた数字かどうかの判定を常にイチから総当たりにしているので、数が多くなればなるほど計算回数が爆発的に増える。したがって、サイズの大きなデータを扱うにはまったく適していないと思うが、せいぜい何十人までのデータを扱うだけならばこれで充分だろう。
シャッフルされた番号をセットしていくマクロ
上掲のgetRandomOrderメソッドによって、シャッフルされた番号のセット（配列）が受け取れるので、あとは配列の中身を順に番号記入セルに入力していけば良い。
リスト２ シートモジュール
Option Explicit
Private Const COLUMN_NUMBERS As String = _
"2 4 7 9 12 14"
Private Const COLUMNS_COUNT As Long = 6 '……(1)'
Private Const MAX_NUMBER As Long = 30
Private Sub setSeatAtRandom()
Dim randOrder() As Long '……(2)'
randOrder = RandUtil.getRandomOrder(MAX_NUMBER, False)
Dim r As Long
Dim c As Long
Dim i As Long
For i = 1 To MAX_NUMBER '……(3)'
r = getRowNumber(i) '……(4)'
c = getColumnNumber(i) '……(6)'
If r = -1 Or c = -1 Then Exit Sub '……(7)'
Me.Cells(r, c).Value = "" '……(8)'
Me.Cells(r, c).Value = randOrder(i - 1)
Call setFontColor(Me.Cells(r, c)) '……(9)'
Next
End Sub
Private Function getRowNumber( _
ByVal number As Long) As Long '……(5)'
Dim ret As Long
ret = -1
If number < 1 Or _
number > MAX_NUMBER Then GoTo Finalizer
On Error GoTo Finalizer
ret = ((number - 1) \ COLUMNS_COUNT) * 3 + 3
Finalizer:
getRowNumber = ret
End Function
Private Function getColumnNumber( _
ByVal number As Long) As Long
Dim ret As Long
ret = -1
If number < 1 Or _
number > MAX_NUMBER Then GoTo Finalizer
On Error GoTo Finalizer
Dim ar() As String
ar = Split(COLUMN_NUMBERS)
Dim targetIndex As Long
targetIndex = (number - 1) Mod COLUMNS_COUNT
ret = CLng(ar(targetIndex))
Finalizer:
getColumnNumber = ret
End Function
Private Sub setFontColor(ByVal targetCell As Range)
Dim rng As Range
Set rng = targetCell.Resize(2, 2) '……(10)'
With targetCell '……(11)'
If .Value = 0 Or .Value = "" Then
rng.Font.Color = vbWhite
Else
rng.Font.Color = vbBlack
End If
End With
End Sub
(1)の
Private Const COLUMNS_COUNT As Long = 6
は、前回
はなかった定数。今回は、getColumnNumberメソッドに加え、getRowNumberメソッドを追加したので、両方に共通する部分を定数にした方が良いと判断した。
(2)の
Dim randOrder() As Long randOrder = RandUtil.getRandomOrder(MAX_NUMBER, False)
では、リスト１のgetRandomOrderメソッドにより、1～30までの数字をランダムに並べ替えた配列を準備。
(3)からの８行
For i = 1 To MAX_NUMBER r = getRowNumber(i) '……(4)' c = getColumnNumber(i) '……(6)' If r = -1 Or c = -1 Then Exit Sub '……(7)' Me.Cells(r, c).Value = "" '……(8)' Me.Cells(r, c).Value = randOrder(i - 1) Call setFontColor(Me.Cells(r, c)) '……(9)' Next
で各番号記入用セルに番号を書き込んでいく。
Forループ内では、まず(4)の
r = getRowNumber(i)
で書き込み先セルの行番号を取得する。
(5)の
Private Function getRowNumber( _
ByVal number As Long) As Long
Dim ret As Long
ret = -1
If number < 1 Or _
number > MAX_NUMBER Then GoTo Finalizer
On Error GoTo Finalizer
ret = ((number - 1) \ COLUMNS_COUNT) * 3 + 3
Finalizer:
getRowNumber = ret
End Function
で、書き込み先セルがいくつ目のセルなのかに応じて行番号を割り出している。
前回ご紹介したgetColumnNumberメソッド同様、あり得ない番号が渡されたときは、-1を返すようにしている。
(6)の
c = getColumnNumber(i)
は、書き込み先セルの列番号取得。
getColumnNumberメソッドの内容については前回を参照のこと。
(7)の
If r = -1 Or c = -1 Then Exit Sub
で取得した値のチェック。
getRowNumberメソッドにせよ、getColumnNumberメソッドにせよ、うまく行っていなかったら-1を返すようにしているので、もしどちらか一方でも-1が返っていたら処理を抜ける。
(8)の
Me.Cells(r, c).Value = "" Me.Cells(r, c).Value = randOrder(i - 1)
で一旦セルの値を消してからシャッフルした番号をぶちこんだ配列の値をセット。
そして、(9)の
Call setFontColor(Me.Cells(r, c))
でsetFonColorメソッドを呼ぶ。
setFonColorメソッド内では、(10)の
Set rng = targetCell.Resize(2, 2)
で、引数で受け取ったtargetCellを２×２の大きさに拡張し、変数rngにぶち込む。
あとは、(11)からの７行
With targetCell If .Value = 0 Or .Value = "" Then rng.Font.Color = vbWhite Else rng.Font.Color = vbBlack End If End With
で、番号入力セルの値に応じてフォントの色を白にしたり、黒にしたりする。
今回のマクロでは「0」とか「""」が入る可能性はないのだけれど、今後の拡張のために入れておいた。
今回用いた座席表の枠では、番号入力セル以外の三つのセルには全てVLOOKUPを用いた数式が入っているので、番号入力セルの値が「0」とか「""」だと、＃N/Aが表示されてしまう。
もちろんIFERRORなんかでネストすれば防げるが、あまり複雑な数式を多用するのもアレなので、このような対応にした。
実行
シート上にコマンドボタンを置いて、今回のマクロを登録、実行してみた。
こんな感じ。
おわりに
実用の場面では、並べ替え用名簿を別に作っておき、シャッフルした後色んな条件で並べ替えてから、座席表に配置するなど、いろいろ工夫すると良いでしょう。
