VBAでBingo5_4
今回は、久し振りに「VBAでBingo5シリーズ」に戻って第４弾として、数値発生件数を増やす処理をします。
その処理に伴い「シートを追加する」処理が今回のメインとなります。
準備
それでは、準備としてBook「練習1.xlsm」をコピーして「B5.xlsm」としてください。
まず、B5.xlsmを開いて、「抽出」「編集」以外のシートをすべて削除してください。
それから、シート「抽出」を下図のように修正してください。
シート「編集」も下図のように縦横5個ずつ計25個分を作りますが、印刷プレビューを見ながら１ページに収まるようにしてください。
VBAのコードは下記のとおりです。微妙に修正していますので時間があれば、違いを探してみてください。
なお、前回までに作ったVBAは、すべて消去した後でコピペしてください。
Sub Pic()
For n = 1 To 25 '1～25まで（25回）繰り返す
For s = 3 To 10 '3(C)列～10(J)列まで⇒列は数値に置換えられる
Cells(n + 2, s) = Application.RandBetween((s - 3) * 5 + 1, (s - 3) * 5 + 5) '抽出範囲を算式で依頼する
Next s
Next n
Edt '編集Procedureへ処理を移す
End Sub
Sub Edt() '発生数値をBingo様式に編集する
Sheets("編集").Select
Cells(3, "N") = "第" & Sheets("抽出").Cells(3, "L") & "回" '回別表示
Cells(3, "R") = Sheets("抽出").Cells(5, "L") '日付表示
For n = 1 To 25
a = Fix((n - 1) / 5) * 4 + 5 '出力基準行番号計算
b = ((n - Fix((n - 1) / 5) * 5) - 1) * 4 + 3 '出力基準列番号計算
Cells(a - 1, b - 1) = Sheets("抽出").Cells(n + 2, "C") '基準点の1行上のひとつ左の列にⅠの値
Cells(a - 1, b) = Sheets("抽出").Cells(n + 2, "D") '基準点の1行上の同じ列にⅡの値
Cells(a - 1, b + 1) = Sheets("抽出").Cells(n + 2, "E") '基準点の1行上のひとつ右の列にⅢの値
Cells(a, b - 1) = Sheets("抽出").Cells(n + 2, "F") '基準点の同じ行のひとつ左の列にⅣの値
Cells(a, b) = Sheets("抽出").Cells(n + 2, "B") '基準点にSETの値
Cells(a, b + 1) = Sheets("抽出").Cells(n + 2, "G") '基準点の同じ行のひとつ右の列にⅤの値
Cells(a + 1, b - 1) = Sheets("抽出").Cells(n + 2, "H") '基準点の1行下のひとつ左の列にⅥの値
Cells(a + 1, b) = Sheets("抽出").Cells(n + 2, "I") '基準点の1行下の同じ列にⅦの値
Cells(a + 1, b + 1) = Sheets("抽出").Cells(n + 2, "J") '基準点の1行下のひとつ右の列にⅧの値
Next n
End Subシート「抽出」の実行ボタン「Picup」をクリックして、25個分が表示されれば準備OKです。
随分長い準備になり、恐縮です。ここまでで、お腹一杯になってそうなのでBreak Timeにしましょう。
本題
それでは、再開して。。。
いよいよここからが本題です。発生件数を任意に設定できるようにして、もし25個を超える場合は、「シートを必要分自動追加する」ような仕掛けを考えます。
ではまず、メインとなる「シートを作成してシート名を変える」部分を「手作業の記録」で作成してみましょう。
マクロの記録を起動してシート「編集」を末尾へコピーして、シート名を「編集2」に変えてみてください。
Sub Macro1()
'
' Macro1 Macro
'
'
Sheets("編集").Select
Sheets("編集").Copy After:=Sheets(2)
Sheets("編集 (2)").Select
Sheets("編集 (2)").Name = "編集2"
End Subができていますか？
必要な部分は Sheets("編集").Copy After:=Sheets(2) と
Sheets("編集 (2)").Name = "編集2"の部分で、これに肉付けしていきますが、暫く置いときます。
処理概要
ここで、処理概要（依頼書の内容）を整理すると、次のとおりです。
①発生件数の処理範囲を1～250として、それ以外はNGメッセージを表示して処理をやめる。
②発生件数によりページ数を計算して、必要なシートを追加し、そのシート名を「編集2」「編集3」…とする。
③発生件数分の処理を繰り返して、予想値をListに出力する。このとき、25件毎にページ替えの処理を行う。
以上です。
ここから、コーディングの始まりです。
①は条件判断なのでIf文になります。ここでは、発生件数(7行目L列)の値が1未満または、250を超えるときに処理をやめたいので、If Cells(7, "L") < 1 Or Cells(7, "L") > 250 Then となります。このようにひとつのIfのなかで複数の条件を取り扱うことも可能ですが、あまり条件が増えると処理が複雑になり、予期しない動きになることもあるので注意が必要です。
Thenの処理は、Msgboxでメッセージを出して、Exit Sub で処理を終了します。（Elseの処理はありません）
次の②が、今回のメインです。
最初に「手作業の記録」でつくったマクロの
Sheets("編集").Copy After:=Sheets(2) を見てみるとシート「編集」を2番目のシートの後ろにコピーしているのがわかります。ここでいう「2番目」のシートや「後ろ」は「一番左のシートを1番目」として、それより「右を後ろ、左を前」と呼んでいます。
これからやりたいことは、新しいシートを順次右へ追加したいと思っています。このままだと、常に「2番目のシートの後ろ」に3番目のシートとしてコピーされるので、順序が逆転することになります。そこで(2)の値を変える必要があります。
また、追加したシートの名前を変えるには、
Sheets("編集 (2)").Name = "編集2" を使いますが、追加したシートに対する「新しい名前」を作ることも必要となります。
それから、シートをつくる「枚数」の情報も必要となります。
25件毎に１枚が必要なので、必要となるシート数を変数Pとすると、
P= Fix((Cells(7, "L") - 1) / 25) + 1の算式で求められます。
また、現存するシート数については、構文 SC = Sheets.Count を使うと変数SCにBook内のシート数を得ることができます。今Book内には「抽出」と「編集」の２種類のシートがありますので、Sheets.Countから１(抽出)を引いた数が「編集」のシート数になります。なので、ここでは
SC = Sheets.Count-1 としておきましょう。
このことから、必要枚数Pが現存数SCを超えたら、シートをつくることになります。
つくるシート数は、For m=1 to P-SC とすれば、1から「必要数から現存数を引いた数(不足している数)」まで繰り返す。ことで、可能となります。
追加する位置は、最後のシートの右側(後ろ)なので最終シート番号を意識することになりますが、ここではSC+mが最終シート番号となります。
シート名「編集2」「編集3」…については、処理開始前の最後のシート名を調べることから始めます。シート名を変数Nuとすると
Nu = Sheets(SC+1).Name で最後のシート名が得られます。SC+1については、ややこしい説明になりますが、前述で「抽出」の分を1引いたので、実際の枚数（最後のシート番号）としては、1を戻しています。
たとえば、最後のシート名が「編集q(qは編集の連番)」だったとすると変数Nuの値は「編集q」となります。ここで必要なものは、qなので「編集」が邪魔になります。そこで Nu = Replace(Nu, "編集", "") とすると編集が消去されqだけが残ります。しかも「編集」は「抽出」を除く全シートに共通なので、常にq(連番)だけが取り出されることになります。
したがって、Nu=qとなり、Nu=q+1 が追加するシートの連番となります。
ただし、最初の「編集」についてはNu=""となるので、Nu=""のときはNu=1に置き換えます。
続いて③はデータを書出す処理になります。
これは、前回の「1から25まで繰り返す」処理を「1から設定値まで繰り返す」に変更します。
そして、繰り返す過程でページ制御を行っていきます。
まず、データの一件目を書き出す前に、Listに残っているデータを消去します。そして、25件目のデータを書き出した後、または最後のデータを書き出した後「Edt」の処理でシート「編集」に書き出します。
設定件数を変数Lnに代入してLn = Cells(7, "L")とすると、繰り返しはFor n=1 to Lnとなります。1行目は「nを25で除して出た余りが1のとき」となります。これを構文にすると n Mod 25 が余りを求める式なので、If文にはめて If n Mod 25 = 1 Then が条件となり、Thenの中ではデータを消去します。構文は Range("C3:J27") = "" で、3行目C列から27行目J列のすべてのセルに空白(””)を代入することで、消去しています。
同様に、25件目の処理は「余りが0」、最後のデータは「nがLnと等しくなったとき」で判断できます。
これも、If文にはめて、Thenの中では Sub Edt に処理を移しますが、このとき書き出すシートの番号を渡すために、変数Snを添付します。この添付された情報はEdtの()に入れてある変数(パラメータ)の中に取込まれます。
最後に Sub Edt を次のように修正してください。
Sub Edt()をSub Edt(SN)に
1行目 Sheets("編集").Select を Sheets(Sn).Select に
完成コードサンプル
参考までに「Pic」の完成形を添付しますが、もしコピペされる際は、既存の「Sub Pic」をEnd Subまで削除するか名前を変えた後、貼り付けてください。
Sub Pic()
'** ①処理範囲を1～250とする
If Cells(7, "L") < 1 Or Cells(7, "L") > 250 Then
MsgBox " 発生件数が想定範囲外です。" & Chr(13) & Chr(13) _
& " １以上250以下の整数を入力して" & Chr(13) _
& " 処理を再開してください。" _
, 16, "Bingo5 nJun"
Exit Sub
End If
'** ②シートを必要分作成する
Sheets("編集").Range("4：22") = "" 'List CLR(4行目～22行目全体のDATAを消去)
P = Fix((Cells(7, "L") - 1) / 25) + 1 '件数に対する頁数
Sc = Sheets.Count - 1 'シート数から「抽出」の枚数(1)を引く
If P > Sc Then '「抽出」を除くシート数を超えたら
Nu = Sheets(Sc + 1).Name '最後のシート名を得る
Nu = Replace(Nu, "編集", "") '最後のシート名から「編集」を消す（番号を得る）
If Nu = "" Then
Nu = 1
End If
For m = 1 To P - Sc '必要分(不足分)のシートをつくる
Sheets("編集").Copy After:=Sheets(Sc + m) '最後のシートの後ろ(右)にシートをコピーする
Sheets(Sc + m + 1).Name = "編集" & Nu + m '増えたシートの名前を変える
Sheets(Sc + m + 1).Range("4:22") = "" '増えたシートのDATAを消去する
Sheets(Sc + m + 1).Range("B2").Select '増えたシートの2行目B列を選択する
Next m
Sheets("抽出").Select
End If
'** ③設定件数分の予想値を発生する
Ln = Cells(7, "L")
For n = 1 To Ln '発生件数分繰り返す
If n Mod 25 = 1 Then 'nを25で除した余りが1のとき
Range("C3:J27") = "" 'List CLR
g = 2 'List 1行目-1
End If
g = g + 1
For s = 3 To 10 '3(C)列～10(J)列まで⇒列は数値に置換えられる
Cells(g, s) = Application.RandBetween((s - 3) * 5 + 1, (s - 3) * 5 + 5) '抽出範囲を算式で依頼する
Next s
If n Mod 25 = 0 Or n = Ln Then 'nを25で除した余りが0 または 最後の処理のとき
Sn = Fix((n - 1) / 25) + 2 '編集シート番号
Edt Sn '編集Procedureへ処理を移す
Sheets("抽出").Select 'シート「抽出」を選択
End If
Next n
End Subこれで、細かい点を抜きにして、おおかた完成です。
また「手作業の記録」で作成したマクロ「Macro1」は必要ないので、削除しても良いです。
入力項目を入れて、実行キー「Pic」をクリックすると
発生件数分が出力されます。
最後までご覧いただき、ありがとうございました。
次回は、より完成度を高めるために、編集シートを一括してPDFに出力す方法を説明する予定です。
この記事が気に入ったらサポートをしてみませんか？