Option Explicit
Option Base 0
'
Public Sub ビンゴシート作成マクロ()
Const BINFNTNA = "MS 明朝" 'フォント名
Const BINFNTSZ = 18 'フォントサイズ
Const BINCELWD = 56 'テーブルセル幅
'---------------------------------------------------------------------------
Dim Ip As Integer, Jp As Integer, Kp As Integer
Dim Lp As Integer
Dim intMat(4, 4) As Integer, intNum(19) As Integer
Dim tblBng As Table
'
'*ビンゴデータ作成
Randomize Timer
For Ip = 0 To 20 - 1
intNum(Ip) = Ip + 1
Next Ip
For Jp = 0 To 5 - 1
For Ip = 0 To 20 - 1
Kp = Int(Rnd(1) * 20)
If Ip = Kp Then Kp = (Ip + 1) Mod 20
Lp = intNum(Kp): intNum(Kp) = intNum(Ip)
intNum(Ip) = Lp
Next Ip
Kp = Int(Rnd(1) * 20)
For Ip = 0 To 5 - 1
intMat(Ip, Jp) = intNum(Kp) + Jp * 20
If intMat(Ip, Jp) > 99 Then
Kp = (Kp + 1) Mod 20
intMat(Ip, Jp) = intNum(Kp) + Jp * 20
End If
Kp = (Kp + 1) Mod 20
Next Ip
Next Jp
'
'*既存の表を削除
For Ip = ActiveDocument.Tables.Count To 1 Step -1
ActiveDocument.Tables.Item(Ip).Delete
Next Ip
'*表作成
Set tblBng = ActiveDocument.Tables.Add( _
Range:=ActiveDocument.Range(Start:=0, End:=0), _
NumRows:=6, NumColumns:=5)
'
'*表設定
With tblBng
.Style = "表 (格子)"
'セル幅
.Columns.SetWidth ColumnWidth:=BINCELWD, _
RulerStyle:=wdAdjustNone
'罫線
With .Borders
.InsideLineStyle = wdLineStyleSingle
.OutsideLineStyle = wdLineStyleSingle
.InsideLineWidth = wdLineWidth100pt
.OutsideLineWidth = wdLineWidth150pt
End With
'*データセット
For Ip = 0 To 5 - 1
With .Cell(1, Ip + 1)
.Range.Text = Mid("BINGO", Ip + 1, 1)
.Range.Font.Name = BINFNTNA
.Range.Font.Size = BINFNTSZ
.Range.ParagraphFormat.Alignment = _
wdAlignParagraphCenter
.VerticalAlignment = wdCellAlignVerticalCenter
End With
For Jp = 0 To 5 - 1
With .Cell(Ip + 2, Jp + 1)
If Ip = 2 And Jp = 2 Then
.Range.Text = "☆"
Else
.Range.Text = StrConv(Format(intMat(Ip, Jp), "00"), vbWide)
End If
.Range.Font.Name = BINFNTNA
.Range.Font.Size = BINFNTSZ
.Range.ParagraphFormat.Alignment = _
wdAlignParagraphCenter
.VerticalAlignment = wdCellAlignVerticalCenter
End With
Next Jp
Next Ip
End With
End Sub