Option Explicit
Public sMsgString As String
'抽選のメイン関数
Public Sub selectPersonMain()
Dim lSelectNo As Long
Call checkPersonList
If checkPersonList = True Then
Call getSelectNo(lSelectNo)
Call setSelectPerson(lSelectNo)
sMsgString = "抽選結果が出ました！！"
End If
' MsgBox sMsgString
End Sub
'引数 lSelectNo Long 参照渡し 当選した人の行数
'リストの数の中で、生成した乱数に一致する行数を取得
Private Sub getSelectNo(ByRef lSelectNo As Long)
Dim lMax As Long
Dim lMin As Long
'一覧の最終行を乱数の最大値にセット
lMax = Cells(Rows.Count, 4).End(xlUp).Row
'乱数の最小値
lMin = 90
'乱数初期化
Randomize
'最小値から最大値の範囲で乱数を生成
lSelectNo = Int((lMax - lMin + 1) * Rnd + lMin)
End Sub
'引数 lSelectNo Long 値渡し 当選した人の行数
'当選した人の情報を当選者欄にセット
Private Sub setSelectPerson(ByVal lSelectNo As Long)
'見た目に動いているようにリストを上から最後まで程よい時間で表示させる
Dim i As Long
Dim l As Long
Dim lMax As Long
lMax = Cells(Rows.Count, 4).End(xlUp).Row
For l = 5 To 5
For i = 90 To lMax
Application.Wait [Now()] + 0.0000001 / 86400
Worksheets("Sheet1").Range("D5").Value = Worksheets("Sheet1").Cells(i, 3).Value
Worksheets("Sheet1").Range("E5").Value = Worksheets("Sheet1").Cells(i, 4).Value
Worksheets("Sheet1").Range("E6").Value = Worksheets("Sheet1").Cells(i, 5).Value
Next i
Next l
Worksheets("Sheet1").Range("D5").Value = Worksheets("Sheet1").Cells(2, 3).Value
Worksheets("Sheet1").Range("E5").Value = Worksheets("Sheet1").Cells(2, 3).Value
Worksheets("Sheet1").Range("E6").Value = Worksheets("Sheet1").Cells(2, 3).Value
'Noをセット
Cells(50, 11).Value = Cells(lSelectNo, 3).Value
'お名前をセット
Cells(50, 12).Value = Cells(lSelectNo, 4).Value & " 様"
'読み仮名をセット
Cells(51, 12).Value = Cells(lSelectNo, 5).Value
'選ばれた社員番号を一桁ずつに分ける
With Range("L53:P53")
.Formula = "=MID(TEXT($K$50,""00000""),COLUMN(A1),1)"
.Value = .Value
End With
'一桁ごとに表示
sMsgString = "5桁目は！"
MsgBox sMsgString
Worksheets("Sheet1").Range("D3").Value = Worksheets("Sheet1").Cells(53, 12).Value
sMsgString = "4桁目は！"
MsgBox sMsgString
Worksheets("Sheet1").Range("E3").Value = Worksheets("Sheet1").Cells(53, 13).Value
sMsgString = "3桁目は！"
MsgBox sMsgString
Worksheets("Sheet1").Range("F3").Value = Worksheets("Sheet1").Cells(53, 14).Value
sMsgString = "2桁目は！"
MsgBox sMsgString
Worksheets("Sheet1").Range("G3").Value = Worksheets("Sheet1").Cells(53, 15).Value
sMsgString = "1桁目は！"
MsgBox sMsgString
Worksheets("Sheet1").Range("H3").Value = Worksheets("Sheet1").Cells(53, 16).Value
Worksheets("Sheet1").Range("D2").Value = Worksheets("Sheet1").Cells(54, 11).Value
'Noをセット
Cells(5, 4).Value = Cells(lSelectNo, 3).Value
'お名前をセット
Cells(5, 5).Value = Cells(lSelectNo, 4).Value & " 様"
'読み仮名をセット
Cells(6, 5).Value = Cells(lSelectNo, 5).Value
'値を入れたセルをクリア
sMsgString = " "
MsgBox sMsgString
Worksheets("Sheet1").Range("D5").Value = Worksheets("Sheet1").Cells(2, 3).Value
Worksheets("Sheet1").Range("E5").Value = Worksheets("Sheet1").Cells(2, 3).Value
Worksheets("Sheet1").Range("E6").Value = Worksheets("Sheet1").Cells(2, 3).Value
Worksheets("Sheet1").Range("D2").Value = Worksheets("Sheet1").Cells(2, 3).Value
Worksheets("Sheet1").Range("D3").Value = Worksheets("Sheet1").Cells(2, 3).Value
Worksheets("Sheet1").Range("E3").Value = Worksheets("Sheet1").Cells(2, 3).Value
Worksheets("Sheet1").Range("F3").Value = Worksheets("Sheet1").Cells(2, 3).Value
Worksheets("Sheet1").Range("G3").Value = Worksheets("Sheet1").Cells(2, 3).Value
Worksheets("Sheet1").Range("H3").Value = Worksheets("Sheet1").Cells(2, 3).Value
'当選者欄に追加
Dim aMax As Long
aMax = Cells(Rows.Count, 9).End(xlUp).Row
Worksheets("Sheet1").Cells(aMax + 1, 9).Value = Worksheets("Sheet1").Range("K50").Value
Worksheets("Sheet1").Cells(aMax + 1, 10).Value = Worksheets("Sheet1").Range("L50").Value
'当選者をリストから削除
Rows(lSelectNo).Delete
End Sub
'一覧未入力、途中抜けの場合のエラーチェック
Private Function checkPersonList() As Boolean
checkPersonList = True
Dim lLastRowName As Long
Dim lTopRowName As Long
lLastRowName = Cells(Rows.Count, 4).End(xlUp).Row
lTopRowName = Cells(90, 4).End(xlDown).Row
'10行目以降に1件も入力されていない場合エラー
If lLastRowName < 90 Then
sMsgString = "抽選対象のリストが入力されていません"
checkPersonList = False
'10行目から最終行の間に、名前が書かれていない行があればエラー
ElseIf lLastRowName <> lTopRowName Then
sMsgString = "抽選対象のリストには、間を開けずに入力してください" & vbCrLf & lTopRowName + 1 & "行目が空欄です"
checkPersonList = False
End If
End Function