エクセルVBAで抽選表を作成 人数でサイズを変更できる

Option Explicit

Public Ar As Long
Public TYsheet, TOsheet, BUsheet As Worksheet
Public TItle, EVD As String
Public Par As Long
Dim Ama As Long

Sub クリアG()
        Set TYsheet = Worksheets("抽選会場")
            With TYsheet
                .Cells.Clear
                .Cells.UseStandardHeight = True
                .Cells.UseStandardWidth = True
            End With
        Range("A1").Select
End Sub

Sub クリアS()
    Dim i As Long
        For i = 1 To Worksheets.Count
                With Worksheets(i)
                    .Cells.Clear
                    .Cells.UseStandardHeight = True
                    .Cells.UseStandardWidth = True
                End With
            Range("A1").Select
        Next i
        Worksheets(1).Range("A1").Select
End Sub

Sub 応募者方眼紙()
    Dim SQRoot As Double  '参加人数の平方根
    Dim Culc As Long      '参加人数-平方近似数の余り
    Dim Syo As Long       '余りの行数
    Dim n As Double       '行列の規模による文字サイズ等の変化数
        Set TYsheet = Worksheets("抽選会場")
        TYsheet.Select
'参加人数の入力チェック
        If 選定ナビ.参加人数.Value = "" Then
            MsgBox "参加人数が入力されていません。" & vbCrLf & _
                "半角数字を入力してください。", vbOKOnly, "メッセージ"
            Exit Sub
        End If
'方眼サイズ計算値を変数に代入
        Par = 選定ナビ.参加人数.Value
        SQRoot = Fix(Sqr(Par))
        Culc = Par - SQRoot ^ 2
        Syo = Culc \ SQRoot
        Ama = Culc Mod SQRoot
'表題表記
        With Range("A1")
            .Value = "【当選者選定プログラム】"
            .Font.Size = 21
            .Font.Bold = True
            .Font.ColorIndex = 32
        End With
'抽選名等情報表示
    TItle = 選定ナビ.抽選名称.Value
    EVD = 選定ナビ.開催日付.Value
        With Range("A3")
            .Value = TItle & "-" & EVD
            .Font.Size = 18
            .Font.Bold = True
            .Font.ColorIndex = 1
        End With
        With Range("J3")
            .Value = "参加人数は、" & Par & "　人です。"
            .Font.Bold = True
            .Font.Size = 15
            .Font.ColorIndex = 18
        End With
'方眼用紙サイズ計算・表示
  '行数
        Select Case Syo
        Case Is > 1
            Ar = SQRoot + Syo
        Case Is = 1
            Ar = SQRoot + 1
        Case Is > 0
            Ar = SQRoot + 1
        Case Is = 0
            Ar = SQRoot
        Case Else
            Ar = SQRoot
        End Select
        If Ama > 0 Then Ar = Ar + 1
        Range(Cells(4, 4), Cells(4 + Ar - 1, 4 + SQRoot - 1)).Select
        Selection.Font.Size = Application.StandardFontSize
  '表示フォントサイズ設定
        Select Case Par
            Case Is < 625
                n = 1
                Selection.Font.Size = 9
            Case Is < 3001
                n = 1
                Selection.Font.Size = 8
            Case Is < 6001
                n = 0.8
                Selection.Font.Size = 7
            Case Is < 10000
                n = 0.8
                Selection.Font.Size = 7
            Case Is < 100000
                n = 0.8
                Selection.Font.Size = 5
            Case Else
                n = 0.6
                Selection.Font.Size = 4
        End Select
  'セルサイズ設定
        With Selection
            .RowHeight = 22.5 * n
            .ColumnWidth = 3.13 * n
            .Interior.ColorIndex = 34
        End With
        Cells.RowHeight = 22.5 * n
        Range("1:3").RowHeight = 22.5
  '用紙行数表示
        With Range("B2")
            .Value = "全" & Ar & "行"
            .Font.Bold = True
            .Font.Size = 15
        End With
        Range("A2").Select
End Sub

Sub 応募者配置乱数()
    Dim i, j As Long
    Dim Tc As Long
    Dim Tr As Long
        Set TYsheet = Worksheets("抽選会場")
        TYsheet.Select
        Randomize
'参加者ID番号に乱数を付与する
        For i = 1 To Par
            Cells(i + 3, 1) = i
            Cells(i + 3, 2) = Rnd
        Next i
'乱数を基準に昇順並べ替えを行なう（方眼紙の番地を決める）
        Range("A4:B" & 3 + Par).Sort key1:=Range("B4"), order1:=xlAscending
'方眼紙のマスに左上~左下、左から右へ参加者IDを記入する
        For i = 1 To Par
            Cells(i + 3, 3) = i
            Tc = i \ Ar
            Tr = i Mod Ar
            If Tr > 0 Then
                Tc = Tc + 1
            ElseIf Tr = 0 Then
                Tr = Ar
            End If
            Cells(Tr + 3, Tc + 3) = Cells(i + 3, 1)
        Next i
'方眼紙未利用番地のセル色削除
        If Ama <> 0 Then
            Range(Cells(Tr + 3 + 1, Tc + 3), Cells(Ar + 3, Tc + 3)).Select
            Selection.Interior.ColorIndex = 0
            Range("A1").Select
        Else
        End If
'4行目以降のA,B,C列の表示内容を変更する
        Range(Cells(12, 1), Cells(Par + 11, 3)).Clear
        Range("A4") = "賞名"
        Range("B4") = "当選者数"
        Range("C4") = "未決数"
'パブリック変数PrN()、PrQ()を表示する
        For j = 1 To 6
            Range("A" & 4 + j) = PrN(j)
            Range("C" & 4 + j) = val(StrConv(PrQ(j), vbNarrow))
        Next j
        Range("A11") = "賞名"
        Range("B11") = "当選順位"
        Range("C11") = "当選者ID"
        With Range("A4:C11")
            .Font.Bold = True
            .Font.Size = 13
            .ColumnWidth = 11
        End With
        With Range("A4:C4")
            .Interior.ColorIndex = 28
        End With
        With Range("A11:C11")
            .Interior.ColorIndex = 28
        End With
        Range("A2").Select
        For i = 5 To 10
            Cells(i, 2) = 0
        Next i
        Columns("A").ColumnWidth = 20
        TYsheet.Select
End Sub