Option Explicit
Dim nPrize As Integer
Dim backupText As String
Dim EmpFirstRound(2000, 6) As String
Dim max As Integer
Sub openForm1()
Dim i, j As Integer
Dim Tepakorn As clsData
Set Tepakorn = New clsData
'-------------------------------------------------------------------- Get data to area variable
Sheets("data").Select
For i = 2 To Tepakorn.Lastrows
For j = 1 To 6
Cells(i, j).Select
EmpFirstRound(i, 0) = i
EmpFirstRound(i, j) = Cells(i, j).Value
Next j
Next i
'-------------------------------------------------------------------- Get data to area variable
max = i - 2
UserForm1.Show
End Sub
Sub startRandom()
Dim xLoop, Litems As Integer
nPrize = Worksheets("config").Cells(3, 2).Value
UserForm1.ListBox1.Clear
If Worksheets("config").Range("R1").Value = 1 Then '-------------- Automatic
For xLoop = 1 To nPrize
Call WaitFor(2)
UserForm1.TextBox1.Value = ""
UserForm1.ListBox1.Clear
' *****************************************************************************************************
Call xRandom ' **************************************************************************
' *****************************************************************************************************
Next xLoop
End If
If Worksheets("config").Range("R1").Value = 2 Then '-------------- one by one
' *****************************************************************************************************
Call xRandom ' **************************************************************************
' *****************************************************************************************************
End If
End Sub
Sub xRandom()
Dim EmpSecondRound(4, 20) As String
Dim nFreeRandom As Integer
Dim T1, T2 As Integer
Dim Lucky As Integer
Dim i, j, nFirstRandom As Integer
'-------------------------------------------------------------------- see config
nFreeRandom = Worksheets("config").Cells(4, 2).Value
UserForm1.Label3.Caption = "¼Ùé⪤´Õ¨Ò¡ " & nFreeRandom & " ¤¹ "
UserForm1.Label2.Caption = "ÊØèÁ" & nFreeRandom & " ¤¹ ¨Ò¡¼ÙéÁÕÊÔ·¸Ô·ÑéËÁ´ "
T1 = Worksheets("config").Cells(3, 5).Value
T2 = Worksheets("config").Cells(4, 5).Value
For i = 1 To nFreeRandom
Again:
' *****************************************************************************************************
Lucky = Int((max - 2 + 1) * Rnd + 2) ' ****************************** first round
' ****************************************************************************************************
' MsgBox EmpFirstRound(Lucky, 1) & "- " & yDuplicate(EmpFirstRound(Lucky, 1))
If xDuplicate(EmpFirstRound(Lucky, 1)) = "yes" Or yDuplicate(EmpFirstRound(Lucky, 1)) = "yes" Then ' EmpFirstRound(Lucky, 1) is an EmpID
GoTo Again '-------- duplicated
Else '--------do not duplicated
UserForm1.ListBox1.AddItem EmpFirstRound(Lucky, 1) & "- " & EmpFirstRound(Lucky, 2) & " " & EmpFirstRound(Lucky, 3)
EmpSecondRound(0, i) = i 'items number
EmpSecondRound(1, i) = EmpFirstRound(Lucky, 1) 'empid
EmpSecondRound(2, i) = EmpFirstRound(Lucky, 2) 'name
EmpSecondRound(3, i) = EmpFirstRound(Lucky, 3) 'lastname
EmpSecondRound(4, i) = EmpFirstRound(Lucky, 6) 'site
Call WaitFor(T1)
nFirstRandom = i
End If
Next i
'-------------------------------------------------------------------- Second Random from area variable -"EmpFirstRound"
Call WaitFor(T2)
' *****************************************************************************************************
Lucky = Int((nFirstRandom - 1 + 1) * Rnd + 1) ' ****************************** second round
' ****************************************************************************************************
For i = 1 To nFirstRandom
If Lucky = EmpSecondRound(0, i) Then
If UserForm1.ListBox2.ListCount = 0 Then
Sheets("backup").Select
Columns("A:A").Select
Selection.ClearContents
End If
UserForm1.TextBox1.Value = EmpSecondRound(1, Lucky) & "-" & EmpSecondRound(2, Lucky) & " " & EmpSecondRound(3, Lucky)
UserForm1.ListBox2.AddItem EmpSecondRound(1, Lucky) & "-" & EmpSecondRound(2, Lucky) & " " & EmpSecondRound(3, Lucky) & " - " & EmpSecondRound(4, Lucky)
End If
Next i
'------------------------------------back up start
' via text file
backupText = EmpSecondRound(1, Lucky) & " - " & EmpSecondRound(2, Lucky) & " " & EmpSecondRound(3, Lucky) & " - " & Now()
Call random9.backup(backupText)
' via excel
Sheets("backup").Select
Call random9.backup2(backupText)
'------------------------------------back up end
UserForm1.TextBox2.Value = UserForm1.ListBox2.ListCount & " of " & nPrize
If UserForm1.ListBox2.ListCount = nPrize Then
MsgBox "Done ! "
End If
Call WaitFor(T2)
End Sub
Sub WaitFor(ByVal NumOfSeconds As Long)
Dim SngSec As Long
SngSec = Timer + NumOfSeconds
Do While Timer < SngSec
DoEvents
Loop
End Sub
Function xDuplicate(luckyPerson As String) As String 'for Listbox2
Dim chk As Integer
For chk = 0 To UserForm1.ListBox2.ListCount - 1
If luckyPerson = GetEmpID(UserForm1.ListBox2.List(chk)) Then
xDuplicate = "yes"
Exit Function
End If
Next chk
xDuplicate = "no"
End Function
Function yDuplicate(luckyPerson As String) As String 'for Listbox1
Dim chk As Integer
For chk = 0 To UserForm1.ListBox1.ListCount - 1
If luckyPerson = GetEmpID(UserForm1.ListBox1.List(chk)) Then
yDuplicate = "yes"
Exit Function
End If
Next chk
yDuplicate = "no"
End Function
'Return an EmpID only (the EmpID form ----empid - name lastname - site)
Function GetEmpID(T As String) As String
Dim C As Integer
For C = 1 To Len(T)
If Mid(T, C, 1) = "-" Then
GetEmpID = Left(T, C - 1)
Exit Function
End If
Next C
End Function
Sub backup(text1 As String) ' ok
'------------------------for back up on note pad
'-----------must reference to " the Microsoft scripting runtime "
Dim FSO As FileSystemObject
Dim FSOFile As TextStream
Dim FilePath As String
Dim NoOfLoop As Integer
FilePath = "D:backUpRandom.txt" ' create a test.txt file or change this
Set FSO = New FileSystemObject
' opens file in write mode
Set FSOFile = FSOTextFile(FilePath, ForAppending, True)
' write your code here
FSOFile.WriteLine (" lucky man----is " & text1)
FSOFile.Close
End Sub
Sub backup2(text1 As String) ' ok
Sheets("backup").Select
Dim i, j
i = 1
j = 1
Do Until Cells(i, 2).Value = "" 'check data last rows existing
i = i + 1
Loop
'if old data more than 20,000 will clear all
If i > 20000 Then
Columns("B:B").Select
Selection.ClearContents
i = 1
End If
Cells(i, 2).Value = text1
Do Until Cells(j, 1).Value = "" 'check data last rows existing
j = j + 1
Loop
Cells(j, 1).Value = text1
End Sub
Sub testx()
Dim a As String
T:
MsgBox "T"
a = InputBox("s", "s")
If a = "t" Then
GoTo T
Else
MsgBox "<>T"
End If
End Sub
Sub testgetID()
Dim textt As String
textt = "1234348 - Thailand"
MsgBox GetEmpID(textt)
End Sub
ฝากข้อความหลังไมค์
Rss Feed
ผู้ติดตามบล็อก : 4 คน [
