I have a variable that is used to determine how many cells are selected randomly. The user enters into an input box the number of gift certificates they have and then the code randomly selects that many winners.
However, when the user enters a number, the number of selected cells is their gift certificates minus 2.
here is the user form code
not sure what is causing it so I posted all of it.
any ideas?
Rich
However, when the user enters a number, the number of selected cells is their gift certificates minus 2.
Code:
Sub gift_cert()
Call gift_cert_mod
End Sub
Private Sub gift_cert_mod()
' This macro requires Microsoft Outlook Object Library (Menu: Tools/References) be available
Dim wb As Workbook
Dim WS As Worksheet
Dim objFolder As Object
Dim objNSpace As Object
Dim objOutlook As Outlook.Application
Dim lngAuditRecord As Long
Dim lngCount As Long
Dim lngTotalItems As Long 'Count of emails in the Outlook folder.
Dim lngTotalRecords As Long
Dim i As Integer
Dim EmailCount As Integer 'The counter, which starts at zero.
Dim pctCompl As Single
Dim objitems As Object
Dim olmail As Variant
Dim mytasks As Object
'
On Error GoTo HandleError
' Initialize:
Set wb = ThisWorkbook
lngAuditRecord = 1 ' Start row
lngTotalRecords = 0
Set WS = Sheets("GC email count")
WS.Cells.ClearContents
'===============================================================================
'READ EMAIL MESSAGES PROCESS
'===============================================================================
Application.ScreenUpdating = False
Set objOutlook = CreateObject("Outlook.Application")
Set objNSpace = objOutlook.GetNamespace("MAPI")
'===============================================================================
'ALLOW USERS TO PICK THE EMAIL FOLDER PROCESS
'===============================================================================
Set objFolder = objNSpace.PickFolder
Set objitems = objFolder.Items
'===============================================================================
'CHECK TO SEE IF USER CANCELLED THE FOLDER PICK PROCESS
'===============================================================================
If objFolder Is Nothing Then
gblStopProcessing = True
MsgBox "Processing cancelled"
Exit Sub
End If
'===============================================================================
'COUNT THE EMAILS IN THE CHOSEN FOLDER
'===============================================================================
Set olmail = objitems.Find("[Subject] = ""thanks a latte""")
If Not (olmail Is Nothing) Then
lngTotalItems = objFolder.Items.Count
'===============================================================================
'IF STATEMENT 'IF COUNT = 0
'===============================================================================
If lngTotalItems = 0 Then
MsgBox "Outlook folder contains no email messages", vbOKOnly + vbCritical, "Error - Empty Folder"
gblStopProcessing = True
GoTo HandleExit
End If
'===============================================================================
'IF STATEMENT 'IF COUNT IS MORE THAN 0
'===============================================================================
If lngTotalItems > 0 Then
On Error Resume Next
WS.Cells(1, 2) = "Received"
WS.Cells(lngAuditRecord, 3) = "Sender Name"
WS.Range("A1").Select
With Selection
.EntireRow.Font.Bold = True
.EntireRow.HorizontalAlignment = xlCenter
End With
'Set olmail = objitems.Find("[Subject] = ""thanks a latte""")
For Each olmail In objitems
If InStr(olmail.Subject, "thanks a latte") > 0 Then
For lngCount = 1 To lngTotalItems
Application.StatusBar = "Reading message " & lngCount _
& " of " & lngTotalItems
With objitems(lngCount)
Cells(lngCount + 1, 2).Formula = .ReceivedTime
Cells(lngCount + 1, 3).Formula = .SenderName
End With
pctCompl = lngCount
progress pctCompl
Next lngCount
UserForm1.Hide
End If
Next olmail
lngTotalRecords = lngCount
' Check that records have been found:
If lngTotalRecords = 0 Then
MsgBox "No records were found for import", vbOKOnly + vbCritical, "Error - no records found"
gblStopProcessing = True
GoTo HandleExit
End If
End If
End If
Dim lrow As Integer
With WS
lrow = Range("B" & Rows.Count).End(xlUp).Row
If lrow = 2 Then Exit Sub
Range("A1").Value = "Email count"
Range("A2") = 1
Range("A2").Select
Selection.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
Step:=1, Stop:=lrow - 1, Trend:=False
Dim RNG As Range
Range("E1").Value = "Gift Certificates"
Range("E2") = 1
Range("E2").Select
Selection.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
Step:=1, Stop:=20, Trend:=False
Range("F1").Value = "Winners"
Range("F2").Select
lrow = Range("E" & Rows.Count).End(xlUp).Row
End With
Call randomme
Set RNG = Range("A").UsedRange
RNG.Select
Columns("A:F").AutoFit
Rows.AutoFit
HandleExit:
On Error Resume Next
Application.ScreenUpdating = True
Set objNSpace = Nothing
Set objFolder = Nothing
Set objOutlook = Nothing
Set WS = Nothing
Set wb = Nothing
If Not gblStopProcessing Then
MsgBox "Processing completed" & vbCrLf & vbCrLf & _
"Please check results", vbOKOnly + vbInformation, "Information"
End If
Exit Sub
HandleError:
MsgBox Err.Number & vbCrLf & Err.Description
gblStopProcessing = True
Resume HandleExit
End Sub
Sub progress(pctCompl As Single)
UserForm1.text.Caption = pctCompl & "% Completed"
UserForm1.Bar.Width = pctCompl * 2
DoEvents
End Sub
Private Sub CommandButton1_Click()
With UserForm1
.StartUpPosition = 0
.Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
.Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
.Show
End With
End Sub
Sub randomme()
'=============================================================================
'Macro assumptions:
'Sheet1 contains random numbers in column A.
'May contain text or blank cells also.
'Columns B and C in Sheet1 are available for
'temporary use by the macro, and do not contain data
'Data will be inserted into Sheet2 in column A
'=============================================================================
Dim CountCells
Dim RandCount
Dim LastRow
Dim Counter1
Dim Counter2
Dim RNG As Range
Dim WS As Worksheet
Set WS = Sheets("GC EMAIL COUNT")
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
WS.Select
Range("A1").Select
Set RNG = Range("F2:F" & LastRow)
'=============================================================================
'quantity of random numbers to pick from
'=============================================================================
CountCells = WorksheetFunction.Count(Range("A:A"))
If CountCells = 0 Then Exit Sub
Dim giftcerts As String
giftcerts = "How many Gift Certificates do you have?"
giftcerts = InputBox(giftcerts, "Gift Certificates")
RandCount = giftcerts
RandCount = Int(RandCount)
If Int(RandCount) <= 0 Or RandCount = False Then Exit Sub
If RandCount > CountCells Then
MsgBox "Requested quantity of numbers is greater " _
& "than quantity of available data"
Exit Sub
End If
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
'=============================================================================
'clear working area
'=============================================================================
Range("N:O").ClearContents
Range("N1").Value = "RANDOM NUMBER"
Range("O1").Value = "RANDOM SORT"
'=============================================================================
'clear destination area
'=============================================================================
RNG.ClearContents
'=============================================================================
'create index for sort use
'=============================================================================
Range("N2") = 1
Range(Cells(3, 14), Cells(LastRow, 14)).DataSeries , Step:=1
'=============================================================================
'create random numbers for sort
'=============================================================================
Range("O2") = "=RAND()"
Range("O2").Copy Range(Cells(2, 15), Cells(LastRow, 15))
WS.Calculate
'=============================================================================
'randomly sort data
'=============================================================================
Range(Cells(1, 1), Cells(LastRow, 15)).Sort Key1:=Range("O2"), _
Order1:=xlAscending, Header:=xlYes, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'=============================================================================
'data has been sorted randomly, cells in column A, rows 1 through
'the quantity desired will be chosen
'=============================================================================
Counter1 = 2
Counter2 = 1
Do Until Counter1 >= RandCount
If IsNumeric(Cells(Counter2, 1).Value) And Cells(Counter2, 1).Value _
<> Empty Then
Range("F" & Counter1) = Cells(Counter2, 1).Value
Counter1 = Counter1 + 1
End If
Counter2 = Counter2 + 1
Loop
'=============================================================================
'resort data into original order and clear working area
'=============================================================================
Range(Cells(1, 1), Cells(LastRow, 15)).Sort Key1:=Range("A1"), _
Order1:=xlAscending, Header:=xlYes, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("N:O").ClearContents
'=============================================================================
'sort work area
'=============================================================================
Range(Cells(1, 6), Cells(LastRow, 6)).Sort Key1:=Range("F2"), _
Order1:=xlAscending, Header:=xlYes, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End Subhere is the user form code
Code:
Private Sub UserForm_Activate()
gift_cert
End Subnot sure what is causing it so I posted all of it.
any ideas?
Rich
