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

2018/11/11 (Sun) 06:44:00

②　五句自動作成


まず五句自動作成版が出来ました。　以下そのVBA codeです（全code）。

---------------------------
' 11/11/2018
' ver2.1 五句作成用
'

Option Explicit

Dim rnd1 As Integer '上の句乱数
Dim rnd2 As Integer
Dim rnd3 As Integer
Dim n As Integer '句総数
Dim m As Integer '五句用カウンター

Private Sub CommandButton2_Click()

Range("H3:J19").Value = ""
Range("H3:J7").Font.ColorIndex = 1

For m = 0 To 4

reDo: '季語なしや季語重なりの場合はやり直し用の乱数を発生する

n = 100

rnd1 = WorksheetFunction.RandBetween(1, n) + 2 '乱数と行番号を合わせる
rnd2 = WorksheetFunction.RandBetween(1, n) + 2
rnd3 = WorksheetFunction.RandBetween(1, n) + 2

'乱数の確認のためセルに書き出す
Cells(9 + m, 8).Value = rnd1
Cells(9 + m, 9).Value = rnd2
Cells(9 + m, 10).Value = rnd3

'季語の赤字のindexを調べる。３なら季語。
Cells(15 + m, 8).Value = Cells(rnd1, 2).Font.ColorIndex
Cells(15 + m, 9).Value = Cells(rnd2, 3).Font.ColorIndex
Cells(15 + m, 10).Value = Cells(rnd3, 4).Font.ColorIndex

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

'季語が一つ有れば良し、ないか二つ以上あればやり直しする
If Cells(15 + m, 8) + Cells(15 + m, 9) + Cells(15 + m, 10) = 5 Then
'MsgBox "季語は合格"
Else
'MsgBox "季語不合格、もう一度"
GoTo reDo '最初に戻る
End If

'作句の季語セルの文字を赤字にする
If Cells(15 + m, 8) = 3 Then Cells(3 + m, 8).Font.ColorIndex = 3
If Cells(15 + m, 9) = 3 Then Cells(3 + m, 9).Font.ColorIndex = 3
If Cells(15 + m, 10) = 3 Then Cells(3 + m, 10).Font.ColorIndex = 3

Next

End Sub

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

説明は次回。

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

2018/11/12 (Mon) 08:47:41

③　五句自動作成codeの説明

簡単に説明すると、前回の一句用のcodeを五回廻せば良いだけです。

・その回数を数えるカウンターｍを使う
・一句出来たらｍを一つ増やし、表示するセルを一行下げる
・これをあと四回繰り返すと、for関数から抜けて完了する

自分で使うならこれで十分ですが、配布用Excelにするためには、Userformで動作するようにこのcodeを部分的に書き替える必要が有ります。

それではまた。

VBA 俳句自動作成ソフト完成！ - Tak

2018/11/14 (Wed) 20:16:51

④　俳句作成ソフト配布版完成

こんなバカなソフト作る人いないと思うけど、興味ある人のために全部のcodeとコメントを載せます。

**************************

Private Sub Auto_Open()　’Excelを立ち上げると、図の様なフォ－ムが立ち上がる
ActiveWindow.WindowState = xlMinimized
UserForm3.Show
End Sub
------------------

'　userForm3用
'　12/14/2018　ver2.1
'　userForm3スタート時auto_open()にする

Private Sub CommandButton1_Click()
Range("H3:J19").Value = "" '前のデータを消しておく
Range("L3:L102").Value = ""
Range("H3:J7").Font.ColorIndex = 1
For m = 0 To 4

reDo: '季語なしや季語重なりの場合はやり直し用の乱数を発生する
n = 100
rnd1 = WorksheetFunction.RandBetween(1, n) + 2 '乱数と行番号を合わせる
rnd2 = WorksheetFunction.RandBetween(1, n) + 2
rnd3 = WorksheetFunction.RandBetween(1, n) + 2
'乱数の確認のためセルに書き出す
Cells(9 + m, 8).Value = rnd1
Cells(9 + m, 9).Value = rnd2
Cells(9 + m, 10).Value = rnd3

'季語の赤字のindexを調べる。３なら季語。
Cells(15 + m, 8).Value = Cells(rnd1, 2).Font.ColorIndex
Cells(15 + m, 9).Value = Cells(rnd2, 3).Font.ColorIndex
Cells(15 + m, 10).Value = Cells(rnd3, 4).Font.ColorIndex

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

'季語が一つ有れば良し、ないか二つ以上あればやり直しする
If Cells(15 + m, 8) + Cells(15 + m, 9) + Cells(15 + m, 10) = 5 Then
'MsgBox "季語は合格"
Else
'MsgBox "季語不合格、もう一度"
GoTo reDo '最初に戻る
End If
　'季語なら赤字にする（sheetでのみ必要）
If Cells(15 + m, 8) = 3 Then Cells(3 + m, 8).Font.ColorIndex = 3
If Cells(15 + m, 9) = 3 Then Cells(3 + m, 9).Font.ColorIndex = 3
If Cells(15 + m, 10) = 3 Then Cells(3 + m, 10).Font.ColorIndex = 3
-------------------------------
'ここからuserformへの転記を行う。　ごった煮の俳句に、季語を赤字にする意味ないので中止。
TextBox1.Text = Cells(3, 8).Value & Cells(3, 9).Value & Cells(3, 10).Value
TextBox2.Text = Cells(4, 8).Value & Cells(4, 9).Value & Cells(4, 10).Value
TextBox3.Text = Cells(5, 8).Value & Cells(5, 9).Value & Cells(5, 10).Value
TextBox4.Text = Cells(6, 8).Value & Cells(6, 9).Value & Cells(6, 10).Value
TextBox5.Text = Cells(7, 8).Value & Cells(7, 9).Value & Cells(7, 10).Value
Next
End Sub
--------------------------------
’俳句作成終了ボタン。　Excelも終了する。
Private Sub CommandButton2_Click()
Unload UserForm3
Application.DisplayAlerts = False
Application.Quit
End Sub
--------------------------------

Private Sub Label7_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
'sheetへ戻れないときの隠れコマンド
Application.WindowState = xlNormal
End Sub

--------------------------
'フォームが立ち上がったら、日付を表示する
Private Sub UserForm_Initialize()
Label7.Caption = Date
End Sub
***************************

終わりで～す。

写真の内容から、タイトル候補を自動で提案するソフトに応用できないかなと考えております。　冬の夜も長くなりそうです。