リーグ戦の試合の表をエクセルで作っても、その結果を入れるのがいまいち面倒です。そこで、入力場所を作っておいて、そこに入れた結果をリーグ戦の表に入れこむマクロを作りました。多少、条件がありますが、できるだけ汎用性高く作ったつもりですので、お役に立つと思い、アップしました。仕事以外ですみません。
使い方
以下の内容を、モジュールにコピーして、リーグ戦のシートにマクロのボタンを設定して、結果をP3：Q4に入力してください。
3行目に番号を、4行目に結果を入力してマクロを動かしてください。
Sub リーグ戦成績入力()
'
' Macro
'条件 NoをB列に設定していること。B列が数字固定されていないと動きません。
'成績の表は、E列から表が作られていること
'6チーム以上のリーグ戦には対応しておりません。
'試合の結果は、P3:Q4に入力してください。
'成績入力のすぐ下に、マクロ開始ボタンを入れるとやりやすいです。
自分 = Cells(3, 16)
相手 = Cells(3, 17)
自分の成績 = Cells(4, 16)
相手の成績 = Cells(4, 17)
番号差 = 相手 - 自分
If 番号差 < 1 Then
MsgBox "番号を確認してください" & vbCrLf & "数字が小さい方を左に入力してください"
End
Else
End If
If 番号差 > 5 Then
MsgBox "番号を確認してください"
End
Else
End If
On Error GoTo エラーの処理
Range("A1").Activate
Columns("B:B").Select
Selection.Find(What:=自分, After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False _
, MatchByte:=False, SearchFormat:=False).Activate
'検索したセルのセル番地を調べて、そのセルをアクティブにする
入力セル番地 = ActiveCell.Address(ColumnAbsolute:=False, RowAbsolute:=False)
検索セル行 = ActiveCell.Row
Range("A1").Activate
Range(入力セル番地).Activate
'検索したセルのブロックを範囲とする。
上のセル行 = 検索セル行 - 1
判定セル = Cells(上のセル行, 2)
If 判定セル = "" Then
Else
'上の区切りの上部まで移動
Selection.End(xlUp).Select
End If
入力セル行上 = ActiveCell.Row
Selection.End(xlDown).Select
入力セル行下 = ActiveCell.Row
範囲 = "B" & 入力セル行上 & ":M" & 入力セル行下
Range(範囲).Select
'範囲中に相手方の番号があるかどうか検索してみる。
Selection.Find(What:=相手, After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False _
, MatchByte:=False, SearchFormat:=False).Activate
'なければ、エラーで飛んで、あれば、そのまま下に継続
何番目 = 検索セル行 - 入力セル行上
選択セル番地 = Selection.Address(ColumnAbsolute:=False, RowAbsolute:=False)
Set ブロック = ActiveSheet.Range(選択セル番地)
ブロック.Cells(何番目 + 1, 何番目 + 番号差 + 4).Select
ブロック.Cells(何番目 + 1, 何番目 + 番号差 + 4) = 自分の成績
ブロック.Cells(何番目 + 番号差 + 1, 何番目 + 4).Select
ブロック.Cells(何番目 + 番号差 + 1, 何番目 + 4) = 相手の成績
Range("P3:Q4").Select
'Selection.ClearContents
進行表
Exit Sub
エラーの処理:
MsgBox "エラーです。何かおかしいです。" & vbCrLf & "番号を確認してみてください。", 49, "エラー"
End Sub
Sub 進行表()
'上記マクロから、進行表のシートに飛んで、今入力した選手の組合せを探して色を付ける。
選手左 = Cells(3, 16)
選手右 = Cells(3, 17)
'MsgBox 選手左 & "-" & 選手右
検索チーム = 選手左 & "-" & 選手右
'MsgBox 検索チーム
Sheets("P11進行表").Select
Cells.Find(What:=検索チーム, After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
False, MatchByte:=False, SearchFormat:=False).Activate
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End Sub
マクロが動く条件
選手には、番号を付けてください。
その選手番号は、B列になるように表を調整してください。もしも、B列でない場合には、 Columns(“B:B”).Select を選手番号がある列に変更してください。また、番号は、計算式では動きませんので、数字としてください。
この表は、B列に番号、C列に選手名、D列に所属チーム名、E列からリーグ結果表となっている前提で作成されております。
仕組みは対応しておりますが、このマクロは、６チーム以上のリーグ戦には、対応しておりません。
ブロックとブロックは、連続せずに、1行以上開けてブロックを作ってください。
試合の結果は、P3：Q4に入力して、その下に、マクロボタンを設定してください。
上記 「成績登録」のボタンをマクロ登録してください。登録するマクロは、 「リーグ戦成績入力 」です。
マクロのファイルは、リーグ戦が記載されているファイルと異なるエクセルファイルでも動きますが、マクロが入ったファイルを保存する場合には、拡張子（ファイル名の後にある”.”以下のもの）をxlmsとしないとマクロが保存できません。もしもリーグ戦が入ったファイルにマクロを登録した場合には、リーグ戦のファイルを新規保管で、xlmsの拡張子で保管してください。マクロを保存せずに、毎回、このホームページに戻ってモジュールにコピペして使ってもそんなに、手間ではないと思います。
マクロ内容の説明
‘（カンマ）が入った部分は、マクロではありません。説明等の補足文なので、無視してよいです。
自分 = Cells(3, 16) 相手 = Cells(3, 17) 自分の成績 = Cells(4, 16) 相手の成績 = Cells(4, 17)
Pは、１６列目
Qは、１７列目
Celles（行、列）の記載方法です。
上記は、エクセルに入力した内容を、変数（自分、相手、自分の成績、相手の成績）に覚えてもらいます。
番号差 = 相手 - 自分
上記の式は、自分の番号と相手の番号の差を計算しております。自分の番号より相手の番号が常に大きい数字なので、相手から自分をマイナスして変数（番号差）としております。後で使います。
If 番号差 < 1 Then
MsgBox "番号を確認してください" & vbCrLf & "数字が小さい方を左に入力してください"
End
Else
End If
If 番号差 > 5 Then
MsgBox "番号を確認してください"
End
Else
End If番号差が０（同じ）または、順番が逆転しているときには、メッセージボックスでエラー通知を行います。
また、このマクロは、リーグ戦5人までとしているので、５より大きい番号差であるとエラー通知を行います。
On Error GoTo エラーの処理 .... Exit Sub エラーの処理: MsgBox "エラーです。何かおかしいです。" & vbCrLf & "番号を確認してみてください。", 49, "エラー"
オンエラー処理です。トランプでいうとオールマイティみたいなカードです。もしもエラーがでたら、最後にあるエラー処理：以後に飛ぶというもので、なんらかしらのエラーがでたら、エラーのメッセージを出すようにしてあります。たとえば、番号が無い番号を入力してしまったとかです。
Columns("B:B").Select
Selection.Find(What:=自分, After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False _
, MatchByte:=False, SearchFormat:=False).ActivateB列を選択して、その中から、自分という変数を探してそのセルを選択します。
'検索したセルのセル番地を調べて、そのセルをアクティブにする
入力セル番地 = ActiveCell.Address(ColumnAbsolute:=False, RowAbsolute:=False)
検索セル行 = ActiveCell.Row
Range("A1").Activate
Range(入力セル番地).Activate選択された、自分の数字があるセル番地を調べて、変数（入力セル番地）に入れて、その行数を後で使う変数（検索セル行）に入れて、一度、A1セルを入力セルとしてから、また、入力セル番地を入力セルにしております。B列のSelectionの範囲から、一度でたかったので、A1に一度飛んで、また、戻ってきてます。
'検索したセルのブロックを範囲とする。
Selection.End(xlUp).Select
入力セル行上 = ActiveCell.Row
Selection.End(xlDown).Select
入力セル行下 = ActiveCell.Row
範囲 = "B" & 入力セル行上 & ":M" & 入力セル行下
Range(範囲).Select今は、B列の自分の番号にセルがいるので、ENDキー上で区切りの上部まで飛んで、その行数を変数（入力セル行上）に覚えてもらって、さらに、ENDキー下で区切りの下に飛んで、変数（入力セル行下）に覚えてもらって、変数（範囲）をB○○M○○というセル番地をつくります。その範囲から、１ブロックのリーグを選択します。
'範囲中に相手方の番号があるかどうか検索してみる。
Selection.Find(What:=相手, After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False _
, MatchByte:=False, SearchFormat:=False).Activateここでは、相手の番号がブロックの中に入っているかを検索しております。あれば、なにもしませんが、無ければ、オンエラーが発動します。
何番目 = 検索セル行 - 入力セル行上
ブロック内の左上から、自分の番号は、何番目なのか、変数（何番目）に計算しておきます。
選択セル番地 = Selection.Address(ColumnAbsolute:=False, RowAbsolute:=False)
Set ブロック = ActiveSheet.Range(選択セル番地)現在、選択されているセル（セルの範囲）を、変数（選択セル番地）に入れて、その選択セル番地のを「ブロック」という範囲にセットします。これで、セットの中で左上が（1,1）と指定できるようになりました。
ブロック.Cells(何番目 + 1, 何番目 + 番号差 + 3).Select
ブロック.Cells(何番目 + 1, 何番目 + 番号差 + 3) = 自分の成績
ブロック.Cells(何番目 + 番号差 + 1, 何番目 + 3).Select
ブロック.Cells(何番目 + 番号差 + 1, 何番目 + 3) = 相手の成績ブロックの範囲の中でまず、自分の行数（何番目＋１で計算）、自分の列数（ 何番目 + 番号差 + 3 で計算）を選択して、そこに自分の成績を入れます。ここで、列の場合が３なのは、番号の他に、氏名と所属名の２列が入っているためで、さらに県名とか入っていれば３が４になります。
下2行は、上記の行と列を入れ替えて、入力セルを計算して相手の成績を入力しています。こちらも同様に列は３です。
Range("P3:Q4").Select
Selection.ClearContents最後に、入力した結果をクリアして、マクロを終わります。
コメント