Re: VBA俳句作成ソフト - Tak

2018/06/16 (Sat) 19:00:11

①　まず10句から始めましょう

河東碧梧桐、松尾芭蕉、正岡子規、高浜虚子、加賀千代、内藤鳴雪、山口誓子、服部嵐雪など有名俳人の句ですのです。

この句を五ー七ー五に分けました。

使った関数は、次の三個です。
・left関数
・find関数
・right関数

Re: VBA俳句作成ソフト - Tak

2018/06/18 (Mon) 09:12:47

②　俳句全句の分割

俳句は原則として空白を入れませんので、先ず上五、中七、下五とそれぞれ別々のセルへ分割して入れましょう。

上図では、上五、中七、下五が分かれてセルに入っています。　実際はセルでいろいろ苦労の数式が入っていますが、その苦労の場面は人には見せないように非表示にしてあります。


ではその場面をお見せします。

Ⓐ　全句

Ⓑ　A列の俳句の文字数を調べます。　=LEN(A2)とB2に書きます。

Ⓒ　最初の空白の位置を調べます。=FIND("　",A2)とB2に書きます。

Ⓓ　次の空白の位置を調べます。=FIND("",A2,FIND("　",A2))とB2に書きます。ここは関数の入れ子になっていて、FIND("　",A2)の後にもう一回FINDで空白位置を調べています。　

Ⓔ　上五の抜き出し：
　　全句（A2）から、最初の空白より前を抜き取ります。　=LEFT(A2,C2-1)と入れます。　C2-1とは最初の空白位置から１を引いた文字数のことです。　C2だけだと、空白も抜き出されて気持ち悪いので-1しました。

Ⓕ　中七の抜き出し：
　　次に、空白（スペース）間の中七だけを抜き出しています。　=MID（文字列A2,最初のスペース位置,次のスペース位置）=MID(A2,C2+1,D2-C2)となります。　+1したりしているのは、やって見ると分かりますが、一文字多かったり少なかったりしますので加減してます。

Ⓖ　下五の抜き出し：
　　最後に文字列の最後から二番目のスペース位置までを抜き出します。　=RIGHT(A2,B2-D2)と書きます。

続く　

Re: VBA俳句作成ソフト - Tak

2018/06/19 (Tue) 16:58:04

③　俳句自動発生code

先の考え(Ⓐ～Ⓖ)に従ってcodeを書いてみます。

上五、中七、下五に振られた乱数の番号に従い、夫々をセルRange("F3")、Range("G3")、Range("H3")に書き込みました。

とんでもない俳句が出来ました。　それぞれは有名俳句なのですが、バラバラにして組みなおしたものがこれです。　句数を増やして、自分の好きな語句を元データに加えていくと、傑作が出来るかもしれません。　或いはできた句を推敲すれば、更に良い句になること必定です。

尚、俳句語句が赤字のものは「季語」です。　この赤文字と言うことを使って、出来た句に必ず季語が入るようにしていきます。

続く

-----------------------------------

Option Explicit
Dim rnd1 As Integer　'上五の文字列に振る乱数
Dim rnd2 As Integer　'中七の文字列に振る乱数
Dim rnd3 As Integer　'下五の文字列に振る乱数

Dim n As Integer　'俳句数

Private Sub CommandButton2_Click()

n =10
rnd1 = WorksheetFunction.RandBetween(1, n)　’1-10までの乱数をrnd1に格納する
rnd2 = WorksheetFunction.RandBetween(1, n)
rnd3 = WorksheetFunction.RandBetween(1, n)

Cells(3, 6).Value = Cells(rnd1 + 2, 2).value　'上五
　　'Cells(3, 6)はRange("F3")と同じです。
Cells(3, 7).Value = Cells(rnd2 + 2, 3).Value '中七
　　'Cells(3, 7)はRange("G3")と同じです。
Cells(3, 8).Value = Cells(rnd3 + 2, 4).Value '下五
　　'Cells(3, 8)はRange("H3")と同じです。

End Sub

-----------------------------

季語を入れる - Tak

2018/06/20 (Wed) 17:13:42

④　季語を必ず一個入れる方法

有名人の俳句ですから季語は入っておりますが、バラバラにして組み合わせた場合には、季語が入らない又は季語重なりも発生します。


それをどうやって解決するかが問題です。　方法は色々有ると思います。　自分のソフトですので、やり方は何でもありです。　いろいろ考えてみましょう。　

一番オーソドックスなのは、季語だけ別データとしてまとめ、出来上がった作句と比べることだと思います。

ただこの方法だと、季語辞典に登録されてい居る季語が2-3千は有るらしいですから、これをデータとするのは肉体労働になるので、もう少しスマートは方法を考えました。

それは、俳句をデータとして書き込む際に、その句の中に使われている季語が、自動作句した句に使われているかどうかを調べることにしました。　

そのための順序は次のようなものです。

１．登録俳句の中の季語の部分を赤字にしておく。
２．自動俳句が出来たら、元の取り込んだ句に赤字（季語）があるかどうかを調べる。　赤字のインデックスは３、黒字のインデックスは1と決まっていますので、上五+中七+下五で５となれば、季語が一個入っていることになります。　
３．もし５なら処理は終了し、作句を書き出します。
４．もし５以外なら、その処理の最初に戻り遣り直します。

パソコンではあっと言う間にこれらの作業を終わらせてくれます。

この処理のcodeを次回書きます（って今から実験します）。

季語を一個入れる - Tak

2018/06/21 (Thu) 08:36:06

⑤　季語を一個入れる方法

１．登録俳句の中の季語の部分を赤字にしました（季語対策を考えて、ここは最初から赤字にしてあります）。


２．元の取り込んだ句（A列）に赤字（季語）があるかどうか次のcodeで調べます。　

'季語の赤字のindexを調べる。３なら季語。　1なら黒で季語なしです。
Range("F13") = Cells(rnd1 + 2, 2).Font.ColorIndex　'Cells(rnd1 + 2, 2)はRange("A"&rnd1)と同じですが、変数を使う場合はCellsをお使いください。
Range("G13") = Cells(rnd2 + 2, 3).Font.ColorIndex
Range("H13") = Cells(rnd3 + 2, 4).Font.ColorIndex

　だからF13+G13+H13の合計が５なら季語は一つと言えるわけです。　

　念のため「季語は合格」、「季語は不合格」とメッセージボックスで表示させてみます。

　季語が一つ有れば良し、ないか二つ以上あればやり直しする。　その判別は次のcodeで。

　If Range("F13") + Range("G13") + Range("H13") = 5 Then
　　　MsgBox "季語は合格"
　　Else　 　
　　　MsgBox "季語不合格、もう一度"
　　Enf If

３．もし季語が一個（合計の数字は5）なら処理は終了し、作句を書き出します。


図には、季語が一個入った例を挙げておきます。

季語不足、重なりのケースは次回で対応します。

Re: 俳句に季語は一個 - Tak

2018/06/22 (Fri) 09:23:44

⑥　季語不合格の場合

　４．もし季語が二つ以上あったり、全くなかったりした場合は次のcode不合格とメッセージがでます。


　　If Range("F13") + Range("G13") + Range("H13") = 5 Then
　　　MsgBox "季語は合格"
　　Else　 　
　　　MsgBox "季語不合格、もう一度"
　　Enf If

その場合の説明図を載せます。

Re: 俳句に季語は一個 - Tak

2018/06/22 (Fri) 20:22:17

⑦　自動俳句作成ソフト完成

季語がだぶったりなかったりしたら、最初からやり直しをさせるgoTo reDoと言う命令文を入れたところが、今までと違うところです。

goto文はスパゲッティになる恐れがあるので、嫌われますが、開発したソフトを自分で使うのであれば、簡潔明瞭なので使っても構わないと思います。


以上を網羅した最終codeを下記に書きます。　理解し易さを第一に考えてますので、少し説明型のcodeになております。

この書き方はほんの一例で、皆さんがどうやりたいかで変ってきます。　自由に改修してください。

----------------------------------
Option Explicit
Dim rnd1 As Integer
Dim rnd2 As Integer
Dim rnd3 As Integer
Dim n As Integer

Private Sub CommandButton2_Click()

reDo: '季語なしや季語重なりの場合は、ここへ戻ってくる。

　n = 30　'俳句数
　rnd1 = WorksheetFunction.RandBetween(1, n)
　rnd2 = WorksheetFunction.RandBetween(1, n)
　rnd3 = WorksheetFunction.RandBetween(1, n)

'乱数の確認のためセルに書き出す、但しsheet上では非表示にしてある。
　Range("F5").Value = rnd1
　Range("G5").Value = rnd2
　Range("H5").Value = rnd3

　'季語の赤字のindexを調べる。３なら季語。
　Range("F13") = Cells(rnd1 + 2, 2).Font.ColorIndex
　Range("G13") = Cells(rnd2 + 2, 3).Font.ColorIndex
　Range("H13") = Cells(rnd3 + 2, 4).Font.ColorIndex

　Cells(3, 6).Value = Cells(rnd1 + 2, 2).Value '上五, Cells(3, 6)はRange("F3")と同じです。
　Cells(3, 7).Value = Cells(rnd2 + 2, 3).Value '中七, Cells(3, 7)はRange("G3")と同じです。
　Cells(3, 8).Value = Cells(rnd3 + 2, 4).Value '下五, Cells(3, 8)はRange("H3")と同じです。

　'季語がないか二つ以上あればやり直しする
　If Range("F13") + Range("G13") + Range("H13") = 5 Then
　　'MsgBox "季語は合格"、合格の場合は何もしないでif文を抜ける。
　Else
　　'MsgBox "季語不合格、もう一度"
　　GoTo reDo '季語がないか、重複しているので最初に戻る。
　End If


End Sub

----------------------------------

図の自動作例（五月雨を香におどろくや仏たち）は、ご存知の芭蕉、蕪村の次の句の一部から出来ております。

上五：芭蕉の「五月雨を集めてはやし最上川」から。

中七：蕪村の「斧入れて香におどろくや冬木立」から。

下五：芭蕉の「菊の香や奈良には古き仏たち」から

VBA寺子屋は俳句の勉強も兼ねております。

お粗末様でした。