オリジナルの出馬表を作成するマクロ
第3回で取得した出馬表（単勝・複勝）からオリジナルの出馬表を作成します。
色付き枠番と馬番を作成
マクロを書く前に「Item」シートを新規に追加して「色付き枠番と馬番」を作っておきます。
標準モジュールを追加したら、分かりやすく「b_出馬表作成」とでもモジュール名を変更して内容を把握しやすいようにします。
- 挿入〜標準モジュールを追加します
- プロパティウインドウのオブジェクト名「Module1」を「b_出馬表作成」とタイプすることでモジュール名を変更できます。頭に「b_」と入れることにより標準モジュールがアルファベット順に並びます。
オリジナル出馬表作成のマクロ
準備ができましたら以下のマクロを書いていきます。
Option Explicit ’以下4行の変数はこのモジュール内のすべてのプロシージャで適用可能な ’モジュールレベル変数です。Sub 出馬表作成()の上の部分で宣言します。 Dim ws2 As Worksheet, ws3 As Worksheet, ws5 As Worksheet Dim tosu As Long Dim rowTop As Integer Dim c As Range Sub 出馬表作成() Dim i As Integer Dim str As String Dim buf1 As Long, buf2 As Long Dim 馬体重 As Long, 増減 As String Set ws2 = Worksheets("Preview") Set ws3 = Worksheets("InpOds") Set ws5 = Worksheets("Item") '■頭数の割り出し ' InpOdsシートのc列馬番の最大値をもとめて該当レースの頭数を割り出す tosu = Application.WorksheetFunction.Max(ws3.Range("c7:c24")) rowTop = 7 '"Preview""InpOds"シートのTop行 '■出馬表に枠番・馬番を貼り付け 'Itemシート上の色つきの枠番・馬番を"Preview"にペースト 1 With ws5 '枠色つきの枠番のペースト .Range(.Cells(2, tosu), .Cells(1 + tosu, tosu)).Copy _ Destination:=ws2.Cells(rowTop, "b") '枠色つき馬番のペースト .Range(.Cells(22, tosu), .Cells(21 + tosu, tosu)).Copy _ Destination:=ws2.Cells(rowTop, "c") End With '■出馬表を作成（馬体重と負担の間に増減列を入れる） ' "InpOds"の出馬表を"Preview"にペースト 2 ws2.Range("d7:h24").Value = ws3.Range("d7:h24").Value ws2.Range("j7:l24").Value = ws3.Range("i7:k24").Value '■馬体重から増減を切り取る 3 rowTop = 6 For i = 1 To tosu str = ws2.Cells(rowTop + i, "h") If str <> "" then '22年8月12日追加 A 馬体重 = Left(str, 3) '馬体重は左から3文字抜き出す 増減 = Mid(str,5, Len(str)-5) ws2.Cells(rowTop + i, "h") = 馬体重 '馬体重プラス時の数値を文字列にして「+」をつける ws2.Cells(rowTop + i, "i") = "'" & 増減 4 End If '22年8月12日追加 Next i '■出馬表のセルの文字位置をそろえる 5 '複勝/増減を右揃え With ws2 .Range(.Cells(rowTop, "f"), .Cells(rowTop + tosu, "f")).HorizontalAlignment = xlRight .Range(.Cells(rowTop, "i"), .Cells(rowTop + tosu, "i")).HorizontalAlignment = xlRight '出馬表の性齢/負担重量を中央揃え .Range(.Cells(rowTop, "g"), .Cells(rowTop + tosu, "g")).HorizontalAlignment = xlCenter .Range(.Cells(rowTop, "j"), .Cells(rowTop + tosu, "j")).HorizontalAlignment = xlCenter End With Call エラーチェックマーク削除 '6 Call 順位をつける '7 Call 罫線を引く '8 Call 十倍未満オッズを赤く '9 End Sub Sub エラーチェックマーク削除() ’エラーチェックマーク削除 はここから書く End Sub Sub 罫線を引く() ’罫線を引く はここから書く End Sub Sub 順位の取得() ’順位の取得 はここから書く End Sub Sub 人気順に並べ替え() ’人気順に並び替え はここから書く End Sub Sub 十倍未満文字赤く() ’十倍未満オッズを赤く はここから書く End Sub Sub 入力オッズと出馬表を消去() ’入力オッズと出馬表を消去 はここから書く End Sub
かいせつ
- 「Item」シートに作った色つき枠番と馬番を「 Preview」シートにコピペ
コピー元のRange(cells(2,tosu),cells(1+tosu,tosu)の列位置はtosuに対応しているので、16頭立ての枠番/馬番は16列目（P列）に配置されています - 馬名から性齢と、負担重量から調教師までを別々に値を貼り付けます
この場合だけ（他にも省略できない場合はありますが）、.Valueは省略できないので書き忘れないで下さい。また、=の左辺（貼り付け先）と右辺（コピー元）は同じ大きさ（同じ行数列数）のセル範囲を指定します - 馬体重が「492(-2)」となっているのを「492」と「-2」に分けます
Aは出走取消があった場合の処理です（22年8月12日追加）。
- 「”‘” & 増減」の「”」ダブルクォーテーションで囲まれた「‘」アポストロフィ（シングルクォーテーション）は、接頭辞と呼ばれる特殊な記号の一種です。接頭辞とはデータの先頭に付ける記号で文字列を表すときの符号として使います。これで馬体重増減の数値は文字列となり「+」記号が付けられます
- 文字位置を揃える
- エラーマークを削除のSubプロシージャを呼び出す
- ランク付けのSubプロシージャを呼び出す
- 罫線を引くのSubプロシージャを呼び出す
- 十倍未満オッズを赤くSubプロシージャを呼び出す
エラーチェックマークの削除
セルの左上に、グリーンの三角形が表示されていることがあります。これはエラーチェックマークと呼ばれ、表示された場合、無視しても特に問題がない場合がほとんどですが、計算結果に間違いが出る恐れもあります。この「エラーチェックマーク」は[ファイル]タブ〜[オプション]〜[数式]〜[エラーチェックルール]〜[文字列形式の数値、またはアポストロフィで始まる数値]のチェックボックスのチェックを外すことで「エラーチェックマーク」を非表示にすることもできます。万が一のリスクを考えるとチェックは入れたままの方がいいかも知れません。
原因として次のようなことが考えられます。ここでは「かいせつの4」で数値を文字列にしたのが原因です。
- 書式が文字列に設定されているセルに数値が入力されたとき
- セルに数値を文字列形式で入力したとき
- セルに入力された数式にエラーがあるとき
- 空白のセルを数式が参照しているとき
マクロを使ってエラーチェックマークを一括で非表示にします。
Sub エラーチェックマーク削除()
Set ws2 = Worksheets("Preview") '1
rowTop = 7
'■頭数の割り出し
' Previewシートのc列馬番の最大値をもとめて該当レースの頭数を割り出す
tosu = Application.WorksheetFunction.Max(ws2.Range("c7:c24"))
'■馬体重増減入力セルのエラーチェックマークを削除 _
（文字列なのでエラーセルになる）
With ws2
For Each c In .Range(.Cells(rowTop, "i"), .Cells(rowTop + tosu - 1, "i")) '2 '3
If c.Errors.Item(xlNumberAsText).Ignore = False Then '4
c.Errors.Item(xlNumberAsText).Ignore = True
End If
Next
End With
End Sub
かいせつ
- 変数ws2はオブジェクトを格納するオブジェクト変数なのでSetを使っています。また変数ws2は当モジュール「b_出馬表作成」の複数のプロシージャで共有できるように、一番上の部分で変数を宣言しています
- For Eachステートメントはループ処理を行う関数です。範囲（ここではi列）などを指定して繰り返す回数が決まります（ここではtosu）
- エラーチェックマークのある馬体重の増減列（i列）の範囲を「c（レンジオブジェクト）」で指定します。
「c.Errors」でエラーになっている単体のセルをRangeオブジェクトで指定、この時セル範囲を指定するとエラーになります
「Item(xlNumberAsText)」ItemのIndex内の定数は文字列形式の数値、またはアポストロフィで始まる数値を含むセルのエラーチェックをします - もしIgnoreプロパティがFalseのとき、つまり「エラーチェックオプション」が設定されていたら、IgnoreプロパティにTrueを設定して「エラーチェックオプション」解除します
罫線を引く
16頭立てなら一つの枠に2頭づつ入りますが、15頭立てだと1枠のみ1頭で2枠以降は2頭づつ入ります。競馬新聞の出馬表のように隣り合った枠に境界の罫線を引くマクロです。
Sub 罫線を引く()
Dim i As Integer
Dim dblwak As Long, trplwak As Long
Dim buf As Long
Set ws2 = Worksheets("Preview")
'■頭数の割り出し
' Previewシートのc列馬番の最大値をもとめて該当レースの頭数を割り出す
tosu = Application.WorksheetFunction.Max(ws2.Range("c7:c24"))
rowTop = 7 '"Preview""InpOds"シートのTop行
'■出馬表に罫線を引く
'★セル左側に縦線を引く 1
For i = 1 To 10 '馬名欄から人気欄まで
With ws2
.Range(.Cells(rowTop, 4 + i), .Cells(rowTop + tosu - 1, 4 + i)) _
.Borders(xlEdgeLeft).LineStyle = xlContinuous
End With
Next i
'★セル下側に横線を引く
'１つの枠に何頭が入っているか？ 2頭枠・3頭枠を調べる 2
dblwak = 9 - (tosu - 8) '9-(tosu-8枠)で何枠以降から2頭入るか調べる
trplwak = 9 - (tosu - 16) '17頭立て以上限定(tosu-16)で何枠以降から3頭入るかを調べる。
'7なら7枠以降が3頭入る
'8頭立てのケース ３
If tosu = 8 Then
For i = 1 To 8
With ws2
Set c = .Range(.Cells(i + 6, "d"), .Cells(i + 6, "m"))
End With
'出馬表横ケイ
c.Borders(xlEdgeBottom).LineStyle = xlContinuous
Next i
End If
'9頭～16頭立てのケース
If tosu >= 9 And tosu <= 16 Then
buf = 1 'ひと枠に2頭入れる場合2行下に横ケイを引く初期値
For i = 1 To 8
If i < dblwak Then '1頭枠の場合ケイを引く '４
With ws2
Set c = .Range(.Cells(i + 6, "d"), .Cells(i + 6, "m"))
End With
'出馬表横ケイ
c.Borders(xlEdgeBottom).LineStyle = xlContinuous
buf = buf + 1 '2頭枠に備え+1にしておく
Else '５
buf = buf + 1
With ws2
Set c = .Range(.Cells(buf + 6, "d"), .Cells(buf + 6, "m"))
End With
'出馬表横ケイ
c.Borders(xlEdgeBottom).LineStyle = xlContinuous
buf = buf + 1
End If
Next i
End If
'17頭立て以上のケース
If tosu >= 17 Then
buf1 = 2 'ひと枠に3頭入れる場合3行下に横ケイを引く初期値
For i = 2 To 16 Step 2 '基本ひと枠2頭
If i / 2 < trplwak Then ’６
With ws2
Set c = .Range(.Cells(i + 6, "d"), .Cells(i + 6, "m"))
End With
'出馬表横ケイ
c.Borders(xlEdgeBottom).LineStyle = xlContinuous
buf = buf + 2
Else '７
buf = buf + 1
With ws2
Set c = .Range(.Cells(buf + 6, "d"), .Cells(buf + 6, "m"))
End With
'出馬表横ケイ
c.Borders(xlEdgeBottom).LineStyle = xlContinuous
buf = buf + 2
End If
Next i
End If
End Sub
かいせつ
出馬表を枠別に横線で区切るのは、8頭・9〜16頭・17〜18頭立てごとに考えてみました。このマクロはもっときれいな書き方があるように思いますので、今後の課題とします。
- 出馬表のセル左側に実線（細）を引く
c.Borders(xlEdgeleft).LineStyle = XLContinuous - 何頭立てかを調べ、何枠から複数頭入るかを算出
2頭入る枠は dblwak= 9ー（頭数ー8） 16頭立てなら1枠から2頭入る
3頭入る枠は trplwak= 9ー（頭数ー16） 17頭立てなら8枠が3頭入る - 8頭立て以下のケース、横ケイを引く
- 9〜16頭立て、一枠1頭のケースの横ケイを引く
- 9〜16頭立て、一枠2頭のケースの横ケイを引く
- 17〜18頭立て、一枠2頭のケースの横ケイを引く
- 17〜18頭立て、一枠3頭のケースの横ケイを引く
ワークシート関数による順位の取得
列Eの単勝配当の低い順（人気順）の順位を取得します。
Sub 順位の取得()
Dim i As Long
Dim rowTop As Long
Dim tosu As Long
Set ws2 = Worksheets("Preview")
'■頭数の割り出し
' InpOdsシートのc列馬番の最大値をもとめて該当レースの頭数を割り出す
tosu = Application.WorksheetFunction.Max(ws2.Range("c7:c24"))
rowTop = 6 '"Preview""InpOds"シートのTop行
For i = 1 To tosu
'取り消し馬には順位を付けない
With ws2
’If .Cells(rowTop + i, "e") = "取消" Then ’1 '22年8月12日 下記に訂正
If .Cells(rowTop + i, "e") = "" Then '2 '22年8月12日 上記を訂正
.Cells(rowTop + i, "m") = ""
Else '3
.Cells(rowTop + i, "m") = Application.WorksheetFunction.Rank _
(.Cells(rowTop + i, "e"), _
.Range(.Cells(rowTop + 1, "e"), .Cells(rowTop + tosu, "e")), 1)
End If
End With
Next i
End Sub
かいせつ
- 訂正前：E列の単勝配当の低い順に順位をつけます。該当馬が「取消」の時は順位を表示するM列は「””」null(ヌル)を使って空欄にします。null(ヌル)とは、プログラミングにおいて、変数データが「何もない」ということを示します
- 訂正後：E列の単勝配当の低い順に順位をつけます。該当馬が取消により「空欄」の時は順位を表示するM列は「””」null(ヌル)を使って空欄にします。null(ヌル)とは、プログラミングにおいて、変数データが「何もない」ということを示します（Sub 馬単()で■入力オッズの「取消」セルを空欄にするを訂正した場合のマクロ）
- 「取消」でないなら、ワークシート関数を使用して順位をM列に表示する
これで人気ランキングを表示した出馬表ができあがりました。
出馬表に次のようなアレンジを加えていきます。
- 単勝人気順に並び替える
- 馬番順に並び替える
- 単勝10倍未満のフォントを赤くする
- データの消去
データの並べ替え
出馬表を単勝の人気順に並べ替えたり、元の馬番順に戻したりできるようにするにはsortメソッドやsortオブジェクトを使います。
Sub 人気順に並べ替え()
Dim tosu As Integer
Set ws2 = Worksheets("Preview")
'■頭数の割り出し
' InpOdsシートのc列馬番の最大値をもとめて該当レースの頭数を割り出す
tosu = Application.WorksheetFunction.Max(ws2.Range("c7:c24"))
With ws2
.Sort.SortFields.Clear ’１
.Range(.Cells(7, "b"), .Cells(tosu + 6, "m")).Sort _
Key1:=.Range("e7"), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1
End With
Call エラーチェックマーク削除 ’2
End Sub
Sub 馬番順に並べる()
Dim tosu As Integer
Set ws2 = Worksheets("Preview")
'■頭数の割り出し
' InpOdsシートのc列馬番の最大値をもとめて該当レースの頭数を割り出す
tosu = Application.WorksheetFunction.Max(ws2.Range("c7:c24"))
With ws2
.Sort.SortFields.Clear ’3
.Range(.Cells(7, "b"), .Cells(tosu + 6, "m")).Sort _
Key1:=.Range("c7"), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1
End With
Call エラーチェックマーク削除
End Sub
かいせつ
人気順に並び替える
- Clearメソッドが実行されないと、前のSortFieldオブジェクトが残ったまま、追加されてしまいます
出馬表のsort範囲を設定、E7の単勝をKey1にして昇順でソート - 並べ替えると再度エラーチェックマークがつくので削除する
馬番順に並び替える
- 馬番順に並び替えたいのでKey1を馬番列のC7に設定
比較演算子を使ってフォントの色を変える
If文の条件式で比較演算子を使って単勝10倍未満のオッズのフォントを赤にします。
Sub 十倍未満オッズを赤く()
Dim i As Long
Dim myHaito As Integer
Set ws2 = Worksheets("Preview")
'■頭数の割り出し
' InpOdsシートのc列馬番の最大値をもとめて該当レースの頭数を割り出す
tosu = Application.WorksheetFunction.Max(ws2.Range("c7:c24"))
rowTop = 6 '"Preview""InpOds"シートのTop行
For i = 1 To tosu
myHaito = ws2.Cells(rowTop + i, "e") '1
If myHaito < 10 Then '2
ws2.Cells(rowTop + i, "e").Font.ColorIndex = 3 '3
End If
Next i
End Sub
かいせつ
- myHaitoに「e列」の単勝配当を順に代入
- 配当が10倍以下か判断
- 配当が10倍以下ならフォントを赤にする
できたら”Preview”シートの上部にコマンドボタンを設置して「馬番順」と「人気順」に切り替えられるようにします。
入力オッズと出馬表を消去
“Preview”シートの出馬表と””Inpods”シートの入力オッズをまとめて消去していますが、別々に消去するにはSubプロシージャを分けます。これもコマンドボタンを設置すると便利です。
Sub 入力オッズと出馬表消去()
Set ws2 = Worksheets("Preview")
Set ws3 = Worksheets("InpOds")
'出馬表の消去
ws2.Range("b7:n24").Clear
'入力オッズの消去
ws3.Range("b7:r364").ClearContents
End Sub
コメント
はじめまして。
オリジナルの出馬表作成したく、たどり着きました。
詳しい内容で、自分でやってみたのですが・・・いかんせ初心者で、
マクロそのものが把握できず、途中でストップです・・・
こんなことぶしつけですが・・・テンプレートありますでしょうか？
できれば、メールいただければ幸いです。
どうかよろしくお願いします。
こんぶり様
ご覧いただきありがとうございます。
ロータス123で多少やっていたとは言え、私も全くの初心者からマクロを学んだので
ご苦労はよく分かります。テンプレートと言うのは特になく、自作のFactorXのマクロのパーツを抜き出して
ブログに載せている状態です。
どこで中断されているか分かりませんが、Tipsにある「マクロのデバッグ」で一行づつ実行され、
エラーになった部分を修正していけばできると思います。
第1回から第4回までできていれば大丈夫です。
今回はお力になれませんでしたが、
今後ともよろしくお願いいたします。
gamira