乱数表(抽選表)の大きさを参加予定人数に合わせて作る-抽選ソフト作成１

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    'セル位置（行）
    
        TYsheet.Select
    '乱数発生のパターン化排除
        Randomize
    '乱数を発生させる
        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
        
    'ソートした順位から乱数表への表示セル位置を決める
        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
        
        Range(Cells(12, 1), Cells(Par + 11, 3)).Clear
        
    '項目の表示
        Range("A4") = "賞名"
        Range("B4") = "当選者数"
        Range("C4") = "未決数"
        
        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