Jim Cone
San Francisco, USA
http://www.realezsites.com/bus/primitivesoftware

Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer

'------------------------------------------------------------------------
'Jun 14, 2003 - Created by Jim Cone - San Francisco, USA
'Generates from 1 to 10 sets of California lotto numbers.
'------------------------------------------------------------------------
Sub GetLottoNumbers()
 On Error GoTo ErrInNumber
 Dim strDefault    As String
 Dim strUserNumber As String
 Dim AlreadyTried  As Boolean
 Dim blnMegaM      As Boolean
 If ActiveSheet Is Nothing Then Exit Sub
 strDefault = " 5 "
StartAgain:
 Application.Cursor = xlDefault
 strUserNumber = InputBox("Enter the number of lottery entries." & vbCr & _
          "(must be 10 or less)" & vbCr & "Press Shift key for Mega Millions", _
          " California Lottery Numbers  ", strDefault)
 blnMegaM = GetKeyState(16) < 0
 DoEvents 'Ensure input box image disappears
 If Len(strUserNumber) = 0 Then
    Exit Sub
 Else
    If (Val(strUserNumber)) < 1 Or Val(strUserNumber) > 10 Then
       If AlreadyTried Then Exit Sub
       AlreadyTried = True
       strDefault = " Your entry must be a number between 1 and 10 "
       GoTo StartAgain
    Else
       ShuffleArrayValues Val(strUserNumber), blnMegaM
    End If
 End If
 Exit Sub
ErrInNumber:
Beep
Application.ScreenUpdating = True
MsgBox "Error  " & Err.Number & " - " & Err.Description & vbCr & _
      "Contact the programs author (James Cone) if the problem persists.  ", _
       vbCritical, " California Lotto Numbers"
End Sub

'==================================================
' GetBottomRow() Function
' Called by ShuffleArrayValues.
' Returns the number of the last worksheet row with data.
'==================================================
Function GetBottomRow(ByRef objSht As Excel.Worksheet) As Long
 On Error GoTo NoRow
 GetBottomRow = objSht.Cells.Find(what:="*", SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious).Row
 Exit Function
NoRow:
 GetBottomRow = 0
End Function

'=========================================
' MaxShtNum() Function
' Created May 05, 2001 by Jim Cone - San Francisco, USA
' Called by ShuffleArrayValues.
' Returns a number between 0 and 100.
'=========================================
Function MaxShtNum() As Long
 On Error GoTo BadSheet
 Dim Sht As Object
 Dim N   As Double
 For Each Sht In ActiveWorkbook.Sheets
     N = WorksheetFunction.Max(N, Val(Right$(Sht.Name, 2)))
 Next 'Sht
 MaxShtNum = N + 1
 Set Sht = Nothing
 Exit Function
BadSheet:
 MaxShtNum = 0
 Set Sht = Nothing
End Function

'====================================================
'Jun 14, 2003 - Created by Jim Cone - San Francisco, USA
'Jun 23, 2005 - Last Update
'Called by Sub "GetLottoNumbers".  
'Requires Functions MaxShtNum and GetBottomRow.
'====================================================
Sub ShuffleArrayValues(ByVal HowMany As Long, ByRef blnM As Boolean)
 Dim i        As Long
 Dim j        As Long
 Dim lngCol   As Long
 Dim lngRow   As Long
 Dim lngMega  As Integer
 Dim lngValue As Integer
 Dim ArrBig() As Integer
 Dim ArrSmall(1 To 5, 1 To 1) As Integer
 Application.ScreenUpdating = False
 i = MaxShtNum
 If blnM Then
    lngValue = 56 'Mega Millions
    lngMega = 46
 Else
    lngValue = 47 'Super Lotto
    lngMega = 27
 End If
 If GetBottomRow(ActiveSheet) = 0 Then 'A blank sheet
    On Error Resume Next
   'Leave a space at end of name so last 2 characters can be read as a number.
    ActiveSheet.Name = "California Lottery Numbers " & i
    On Error GoTo 0
    lngRow = 5
 ElseIf Not ActiveSheet.Name Like "*California Lottery Numbers*" Then
    Worksheets.Add Before:=ActiveSheet, Count:=1
    On Error Resume Next
    ActiveSheet.Name = "California Lottery Numbers " & i
    On Error GoTo 0
    lngRow = 5
 Else
    lngRow = Cells(Rows.Count, 2).End(xlUp).Row + 3
   'Extra rows required for the array
    If lngRow + 7 > Rows.Count Then
       Application.Cursor = xlDefault
       MsgBox "Have run out of rows.   ", vbExclamation, " California Lottery Numbers"
       Exit Sub
    End If
 End If
 For lngCol = 3 To (HowMany + 2)
     j = 1
     ReDim ArrBig(1 To lngValue)
     
     Do While j < 6
        Randomize (Right(Timer, 2) * j)
       'Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
        i = Int(Rnd * lngValue + 1)
        If ArrBig(i) <> 99 Then
           ArrSmall(j, 1) = i
           ArrBig(i) = 99
           j = j + 1
        End If
     Loop
    'Add array values to the worksheet.
     With Range(Cells(lngRow, lngCol), Cells(lngRow + 4, lngCol))
         .Value = ArrSmall()
         .Sort key1:=Cells(lngRow, lngCol)
     End With
    'Get another random number ("Mega") and add to worksheet.
     Randomize (Right(Timer, 2) * lngCol)
     Cells(lngRow + 6, lngCol).Value = Int((Rnd * lngMega) + 1)
     Erase ArrBig
     Erase ArrSmall
 Next 'lngCol
'Format the new worksheet.
 Rows(lngRow + 6).VerticalAlignment = xlTop
 With Range(Cells(lngRow, 2), Cells(lngRow + 6, lngCol - 1))
     .RowHeight = ActiveSheet.StandardHeight + 2
     .Interior.Color = vbWhite
     .HorizontalAlignment = xlCenter
     .Columns.ColumnWidth = ActiveSheet.StandardWidth - 1
     .BorderAround LineStyle:=xlContinuous
      With .Borders(xlInsideVertical)
           .LineStyle = xlDash
           .Weight = xlHairline
      End With
 End With
 With Range(Cells(lngRow, 2), Cells(lngRow + 6, 2))
     .Interior.ColorIndex = 15
     .Font.Bold = True
      If blnM Then 'Mega Millions
        .Value = WorksheetFunction.Transpose _
                      (Array("M", "E", "G", "A", "Millions", "", "MEGA"))
      Else
        .Value = WorksheetFunction.Transpose _
                      (Array("L", "O", "T", "T", "O", "", "MEGA"))
      End If
 End With
 Columns(1).ColumnWidth = ActiveSheet.StandardWidth \ 2
 With Range("B2")
      If Len(.Value) = 0 Then .Value = "Lottery Numbers Created on " & Date
 End With
 Do While ActiveWindow.VisibleRange.Rows _
         (ActiveWindow.VisibleRange.Rows.Count).Row < lngRow + 7
    ActiveWindow.ScrollRow = ActiveWindow.VisibleRange.Row + 1
 Loop
 Application.ScreenUpdating = True
End Sub
'------------------

"Max" <demechanik@yahoo.com>
wrote in message
"Jim Cone" <jim.coneXXX@rcn.comXXX> wrote

Max
Singapore
http://savefile.com/projects/236895
xdemechanik