予測を行うためのマクロ

lottery

'パラメーター用変数
Dim RowCnt As Integer
Dim LotCnt As Integer
Dim Min As Integer
Dim Max As Integer
Dim NumMax As Integer
Dim MatchMax As Integer
'チェック用に設定された数字を入れる配列
Dim CheckNum() As Integer
'予想数を一時的に保存する配列
Dim Box() As Integer
'予想する数字を入れる配列
Dim LotteryNum() As Integer
'チェック試行回数
Dim TrialCnt As Long

Sub lottery()

'過去データの削除
Range("N:Z").ClearContents

'各パラメーターの設定＆取得
RowCnt = Range("L3").Value - 1
LotCnt = Range("L4").Value - 1
Min = Range("L5").Value - 1
Max = Range("L6").Value - 1
NumMax = Range("L7").Value - 1
MatchMax = Range("L8").Value
ReDim CheckNum(RowCnt, NumMax)
ReDim Box(NumMax)
ReDim LotteryNum(LotCnt, NumMax)
TrialCnt = 0

'チェック数値の設定
For i = 0 To RowCnt
    For j = 0 To NumMax
        CheckNum(i, j) = Cells(1 + i, 1 + j).Value
    Next
Next

'乱数系列を初期化
Randomize

For i = 0 To LotCnt
    '抽選の実行
    Call LotBox
    If CheckBox() = True Then
        i = i - 1
    Else
        For j = 0 To NumMax
            LotteryNum(i, j) = Box(j)
        Next
    End If
    
    'ステータスバーに試行回数を表示
    TrialCnt = TrialCnt + 1
    '試行回数が一定値を超えた場合のエラー処理
    If TrialCnt >= 10000 And TrialCnt Mod 10000 = 1 Then
        Call Message
    End If
    Application.StatusBar = "決定:" & i + 1 & "/" & LotCnt + 1 & "   試行回数:" & TrialCnt
Next

'表示
For i = 0 To LotCnt
    For j = 0 To NumMax
    Cells(3 + i, 14 + j).Value = LotteryNum(i, j)
    Next
Next

'ソートの実行
For i = 3 To LotCnt + 3
Call Range("N" & i, "Z" & i).Sort( _
  Key1:=Range("N" & i), _
  Order1:=xlAscending, _
  Orientation:=xlSortRows)
Next

'ステータスバーの表示を消す
'Application.StatusBar = ""

End Sub

'重複無く一定範囲の数値抽選を行う
Private Sub LotBox()
    '重複チェック用
    Dim flg() As Boolean
    ReDim flg(Max + 1)

    '抽選数字
    Dim num As Integer

    For cnt = 0 To NumMax
        Do
            num = Int((Max + 1) * Rnd + 1)
        Loop While flg(num)
        
        flg(num) = True
        Box(cnt) = num
    Next
End Sub

'チェック用の数字との重複を調べる
Private Function CheckBox() As Boolean
    Dim cnt As Integer: cnt = 0
    For i = 0 To RowCnt
        For j = 0 To NumMax
            For k = 0 To NumMax
                If CheckNum(i, j) = Box(k) Then
                    cnt = cnt + 1
                End If
            Next
            If cnt >= MatchMax Then
                CheckBox = True
                Exit Function
            End If
        Next
        cnt = 0
    Next
    
    CheckBox = False
    
End Function

'終了を聞くメッセージボックス
Private Sub Message()
    Dim rc As VbMsgBoxResult
    rc = MsgBox("処理を続ける？", vbYesNo + vbExclamation)
    If rc = vbYes Then
        MsgBox "まじか…"
    Else
        MsgBox "だよね"
        End
    End If
End Sub