Count what number that appears the most. In VBScript - vbscript

I got this comma separated file with a bunch of numbers
The only thing that I need to be able to do is to find what number that appears the most time
Ex:
817;9;516;11;817;408;9;817
then the result will be 817
I hope you understand what I am trying to do.

I would suggest using the FileSystemObjects, specifically the OpenTextFile method to read the file, then use split function to separate based on columns. Then iterate the array returned, and count the number of times each number occurs.
The following code will count your array for you. It uses the useful Dictionary object.
Set counts = CreateObject("Scripting.Dictionary")
For i = Lbound(arr) to Ubound(arr)
If Not counts.Exists(arr(i)) Then
counts.add arr(i), 1
Else
currCount = counts.Item(arr(i))
counts.Item(arr(i)) = currCount + 1
End If
Next
nums = counts.Keys()
currMax = 0
currNum = 0
For i = Lbound(nums) to Ubound(nums)
If counts.Item(nums(i)) > currMax Then
currMax = counts.Item(nums(i))
currNum = nums(i)
End If
Next
num = currNum ' Most often found number
max = currMax ' Number of times it was found

i would go through the text and count the number of your nubmers.
after that i would redim an dynamic array.
- go throught the text from beginning to end, and store them in the array.
after that i would pick the first number, go through the array and count (for example in tmpcounter) the number of dublicates. [you could store the counted number from the textfile in tmphit]
the you pick the second number, count the number of dublicates ( tmpcounter2 /tmphit2)
compare the two counters,you "keep" the higher one and use the lowe one for the next number
...go on until the last field is validated.
at the end you know which number appearse most and how often.
i hope this help you.
this is how i would programm it, maybe there is a better way or an API.
at the end you know

Try this
Set objFile = CreateObject("Scripting.FileSystemObject").OpenTextFile("C:\Test.txt",1)
Set dictNumbers = CreateObject("Scripting.Dictionary")
Dim MostKey
intHighest = -1
do while NOT objFile.AtEndOfStream
LineArray = Split(objFile.ReadLine,";")
for i = 0 to UBound(LineArray)
if dictNumbers.Exists(LineArray(i)) Then
dictNumbers.Item(LineArray(i)) = dictNumbers.Item(LineArray(i)) + 1
else
dictNumbers.Add LineArray(i), 1
end if
if dictNumbers.Item(LineArray(i)) > intHighest Then
intHeighest = dictNumbers.Item(LineArray(i))
MostKey = LineArray(i)
end if
next
Loop
MsgBox MostKey

Related

Why does my "random key code" creates a same key every once in a while?

I`m having the following code from which I extract randomPW for my db.
I need this string of random characters in order to use it a primary key in my Db. The problem is that I`m getting quite a lot of duplicates when I execute this code more than once or if I get a Loop in order to extract (for example) 100 keys at once.
If I try to reload the page in order to insert one by one key the same problem occurs... every 50-80 reloads there is a duplicate. What's wrong with my code?
<%
Function RandomPW(myLength)
Const minLength = 6
Const maxLength = 20
Dim X, Y, strPW
If myLength = 0 Then
Randomize
myLength = Int((maxLength * Rnd) + minLength)
End If
For X = 1 To myLength
Y = Int((3 * Rnd) + 1) '(1) Numeric, (2) Uppercase, (3) Lowercase
Select Case Y
Case 1
'Numeric character
Randomize
strPW = strPW & CHR(Int((9 * Rnd) + 48))
Case 2
'Uppercase character
Randomize
strPW = strPW & CHR(Int((25 * Rnd) + 65))
Case 3
'Lowercase character
Randomize
strPW = strPW & CHR(Int((25 * Rnd) + 97))
End Select
Next
RandomPW = strPW
End Function
%>
I expect my code to extract a string that will not duplicate every now and then.
I need this string of random characters in order to use it a primary key in my Db.
In this case I would recommend to use Scriptlet.TypeLib :
Function RandomPW(myLength)
Set TypeLib = CreateObject("Scriptlet.TypeLib")
If myLength < Len(TypeLib.Guid)
RandomPW = Left(TypeLib.Guid, myLength)
Else
RandomPW = TypeLib.Guid
End If
End Function
Randomize is not supposed to be used more than once, unless you want to make sure you are creating fake, repeatable randomness. Per docs, helpfully linked by Lankymart (emphasis mine):
Randomize uses number to initialize the Rnd function's random-number generator, giving it a new seed value. If you omit number, the value returned by the system timer is used as the new seed value.
The system timer referred to above is in seconds; which means, successive calls to Randomize in short succession will make sure the following Rnd is yielding the same value.
It would likely help you immensely to remove all calls to Randomize.

Iterate over all selected rows of SSDBGrid to fill an array

I need to iterate over all of the selected rows in an SSDBGrid. Then, I need to get the value in the current row and populate the relevant place in the array with this value.
I've been attempting to do this with the code below:
Dim i As Integer
i = 0
Dim nomCode(Grd_Nominal.SelBookmarks.Count) As String ' This is my array.
Do While Grd_Nominal.SelBookmarks <> 0
nomCode(i) = Grd_Nominal.SelBookmarks(0)
If Grd_Nominal.SelBookmarks.Count > 0 Then
Grd_Nominal.SelBoomarks(0).Remove
End If
i = i + 1
Loop
However, nomCode(i) is always being filled as nomCode(i) = "??"
Why is it inserting "??", and how can I fix this to insert the value of the current row?
You need to first of all re-think how you're declaring your array.
Dim nomCode() As String
ReDim nomCode(Grd_Nominal.SelBookmarks.Count - 1) As String
This is because when declaring an array you need to pass in a constant as the length. ReDim doesn't, so this will go partly towards solving the issue.
Dim x As Integer
Dim bk As Variant
For x = 0 to Grd_Nominal.Rows.Count - 1
bm = Grd_Nominal.SelBookmarks(x)
nomCode(x) = Grd_Nominal.Columns("Your_Column").CellValue(bm)
Next
This should sort the rest of the issue, I think.

Looping error, too many records added

Ive been trying to write Access VBA code to automate the addition of replicates for germination tests.
Basically I have a form where I enter the total number of Reps (NoofReps) and the number of seeds per rep (RepSize) (e.g. 50 seeds). For each record added I want it to automatically add a record for each rep and automatically calc the Rep Number (i.e if i have 4 reps then it should add 4 records, numbered 1-4 reps) as well as the RepSize (e.g 50).
I have been trying out various loops based on information from this forum and other but am still getting errors with the number of records that it generates. I have tried both the "Do while" and "Do Until" but get the same result below either way.
Could someone please let me know where I am going wrong?...If i want 2 reps then it adds 2, If i want 3 then its 246, and if i want 4 it adds >30,000!!!
For the purposes of trying to fix the code I have started to type the number of reps manually into the code in the iNoofReps so that I know the error is in the code and not from the form.
Private Sub CmdAddReps3_Click()
Dim iRepNo As Integer ' stores the current value in the series
'Open the table
Set db = CurrentDb()
Set rstGReps = db.OpenRecordset("tblGReplicates")
' Initialise the variables
iRepNo = 1
iNoofReps = 3 'iNoofReps = Me.txtNoofReps
' Add the records using a loop
rstGReps.movefirst
Do 'Until rstGReps("RepNo") = (iNoofReps + 1) ' always want to include at least 1 repNo
rstGReps.AddNew
rstGReps("GTestID") = Me.GTestID
rstGReps("RepNo") = iRepNo
rstGReps("NoofSeed") = Me.txtNoOfSeeds
' Calculate the next RepNo value in the loop
iRepNo = iRepNo + 1
rstGReps.Update
rstGReps.moveNext
Loop Until rstGReps("RepNo") = (iNoofReps) + 1 ' so that the loop includes the final repNo.
MsgBox "Finished Looping"
rstGReps.Close
Set rstGReps = Nothing
Set db = Nothing
End Sub
Any help would be appreciated!!!
Well, you're moving next here: rstGReps.moveNext, and then you're comparing rstGReps("RepNo") = (iNoofReps) + 1 after moving next, thus being on an empty record, thus always equating to false.
Loop Until iRepNo = (iNoofReps) + 1 should fix it, then you're no longer referring to the recordset, which has already been set to the next record by the time you're referring to it.
You could also fix it by just eliminating this line:
rstGReps.moveNext
Since rstGReps.AddNew already moves the recordset to a new blank record, moving it forward after adding the record doesn't make much sense. If you remove it, you might want to remove the + 1 in Loop Until rstGReps("RepNo") = (iNoofReps) + 1

Assign values in a loop in Classic ASP

I have this setup here:
'highest number of days and lowest
niedrigsterTag = 8
hoechsterTag = 8
dim tageV(), tageB()
redim tageV(7), tageB(7)
'day-mapping
tageV(0) = replace(rs("TagVon"),"Mo", 1)
tageV(1) = replace(rs("TagVon"),"Di", 2)
tageV(2) = replace(rs("TagVon"),"Mi", 3)
tageV(3) = replace(rs("TagVon"),"Do", 4)
tageV(4) = replace(rs("TagVon"),"Fr", 5)
tageV(5) = replace(rs("TagVon"),"Sa", 6)
tageV(6) = 7
'for example: mo - fr
for each item in tageV
'save smallest weekday
if(isNumeric(item)) then
if(item <= niedrigsterTag) then
niedrigsterTag = item
Response.write(niedrigsterTag)
response.end()
end if
end if
next
As you might see, I'm pretty new into classic ASP. I don't understand what I'm missing on my loop. In pseudocode, it looks fine:
for each numeric value in my array, check if the current value of item is <= the current maxValue (hoechsterTag) - which is in the first iteration 8. If so, override the current value.
Now I'm stuck. I added a response.end() in the most-inner if. However, niedrigsterTag has a value of 7 instead of 1. Also, during the 1st iteration, item should be 1, right? For me it is 7. I imagined response.end() is an equivalent to PHP's die()
What I'm trying to realize:
if current iteration < current value, override it, so I'm ending up with the smallest value.
I know this is pretty basic, and so far I hadn't problems doing stuff like this in other languages. Don't know why this makes it so special.
Thank you for any hints and advices
When you are assigning the values to your tageV array, you are assigning them as strings and then comparing them to integers. You need to compare like datatypes for one.
Also, they way it is written is like this: In the first iteration, if the item is 1 and niedrigsterTag is 8 then niedrigsterTag is changed to 1 and response.end stops the loop and exits. What you need is more like this:
'highest number of days and lowest
niedrigsterTag = 8
hoechsterTag = 8
dim tageV(), tageB()
redim tageV(7), tageB(7)
'day-mapping
tageV(0) = replace(rs("TagVon"),"Mo", 1)
tageV(1) = replace(rs("TagVon"),"Di", 2)
tageV(2) = replace(rs("TagVon"),"Mi", 3)
tageV(3) = replace(rs("TagVon"),"Do", 4)
tageV(4) = replace(rs("TagVon"),"Fr", 5)
tageV(5) = replace(rs("TagVon"),"Sa", 6)
tageV(6) = 7
'for example: mo - fr
for each item in tageV
'save smallest weekday
if(CInt(item) <= niedrigsterTag) then
niedrigsterTag = CInt(item)
end if
next
Response.write("niedrigsterTag = " & niedrigsterTag)
This loops through the array and every time it finds a smaller value, the variable is assigned that value. Once the loop is done, the variable will hold the smallest value.
By the way, the reason you were getting 7 was because that was the only value that was making it past the if statements.

Formula for calculating Exotic wagers such as Trifecta and Superfecta

I am trying to create an application that will calculate the cost of exotic parimutuel wager costs. I have found several for certain types of bets but never one that solves all the scenarios for a single bet type. If I could find an algorithm that could calculate all the possible combinations I could use that formula to solve my other problems.
Additional information:
I need to calculate the permutations of groups of numbers. For instance;
Group 1 = 1,2,3
Group 2 = 2,3,4
Group 3 = 3,4,5
What are all the possible permutation for these 3 groups of numbers taking 1 number from each group per permutation. No repeats per permutation, meaning a number can not appear in more that 1 position. So 2,4,3 is valid but 2,4,4 is not valid.
Thanks for all the help.
Like most interesting problems, your question has several solutions. The algorithm that I wrote (below) is the simplest thing that came to mind.
I found it easiest to think of the problem like a tree-search: The first group, the root, has a child for each number it contains, where each child is the second group. The second group has a third-group child for each number it contains, the third group has a fourth-group child for each number it contains, etc. All you have to do is find all valid paths from the root to leaves.
However, for many groups with lots of numbers this approach will prove to be slow without any heuristics. One thing you could do is sort the list of groups by group-size, smallest group first. That would be a fail-fast approach that would, in general, discover that a permutation isn't valid sooner than later. Look-ahead, arc-consistency, and backtracking are other things you might want to think about. [Sorry, I can only include one link because it's my first post, but you can find these things on Wikipedia.]
## Algorithm written in Python ##
## CodePad.org has a Python interpreter
Group1 = [1,2,3] ## Within itself, each group must be composed of unique numbers
Group2 = [2,3,4]
Group3 = [3,4,5]
Groups = [Group1,Group2,Group3] ## Must contain at least one Group
Permutations = [] ## List of valid permutations
def getPermutations(group, permSoFar, nextGroupIndex):
for num in group:
nextPermSoFar = list(permSoFar) ## Make a copy of the permSoFar list
## Only proceed if num isn't a repeat in nextPermSoFar
if nextPermSoFar.count(num) == 0:
nextPermSoFar.append(num) ## Add num to this copy of nextPermSoFar
if nextGroupIndex != len(Groups): ## Call next group if there is one...
getPermutations(Groups[nextGroupIndex], nextPermSoFar, nextGroupIndex + 1)
else: ## ...or add the valid permutation to the list of permutations
Permutations.append(nextPermSoFar)
## Call getPermutations with:
## * the first group from the list of Groups
## * an empty list
## * the index of the second group
getPermutations(Groups[0], [], 1)
## print results of getPermutations
print 'There are', len(Permutations), 'valid permutations:'
print Permutations
This is the simplest general formula I know for trifectas.
A=the number of selections you have for first; B=number of selections for second; C=number of selections for third; AB=number of selections you have in both first and second; AC=no. for both first and third; BC=no. for both 2nd and 3rd; and ABC=the no. of selections for all of 1st,2nd, and third.
the formula is
(AxBxC)-(ABxC)-(ACxB)-(BCxA)+(2xABC)
So, for your example ::
Group 1 = 1,2,3
Group 2 = 2,3,4
Group 3 = 3,4,5
the solution is:: (3x3x3)-(2x3)-(1x3)-(2x3)+(2x1)=14. Hope that helps
There might be an easier method that I am not aware of. Now does anyone know a general formula for First4?
Revised after a few years:-
I re logged into my SE account after a while and noticed this question, and realised what I'd written didn't even answer you:-
Here is some python code
import itertools
def explode(value, unique):
legs = [ leg.split(',') for leg in value.split('/') ]
if unique:
return [ tuple(ea) for ea in itertools.product(*legs) if len(ea) == len(set(ea)) ]
else:
return [ tuple(ea) for ea in itertools.product(*legs) ]
calling explode works on the basis that each leg is separated by a /, and each position by a ,
for your trifecta calculation you can work it out by the following:-
result = explode('1,2,3/2,3,4/3,4,5', True)
stake = 2.0
cost = stake * len(result)
print cost
for a superfecta
result = explode('1,2,3/2,4,5/1,3,6,9/2,3,7,9', True)
stake = 2.0
cost = stake * len(result)
print cost
for a pick4 (Set Unique to False)
result = explode('1,2,3/2,4,5/3,9/2,3,4', False)
stake = 2.0
cost = stake * len(result)
print cost
Hope that helps
AS a punter I can tell you there is a much simpler way:
For a trifecta, you need 3 combinations. Say there are 8 runners, the total number of possible permutations is 8 (total runners)* 7 (remaining runners after the winner omitted)* 6 (remaining runners after the winner and 2nd omitted) = 336
For an exacta (with 8 runners) 8 * 7 = 56
Quinellas are an exception, as you only need to take each bet once as 1/2 pays as well as 2/1 so the answer is 8*7/2 = 28
Simple
The answer supplied by luskin is correct for trifectas. He posed another question I needed to solve regarding First4. I looked everywhere but could not find a formula. I did however find a simple way to determine the number of unique permutations, using nested loops to exclude repeated sequences.
Public Function fnFirst4PermCount(arFirst, arSecond, arThird, arFourth) As Integer
Dim intCountFirst As Integer
Dim intCountSecond As Integer
Dim intCountThird As Integer
Dim intCountFourth As Integer
Dim intBetCount As Integer
'Dim arFirst(3) As Integer
'Dim arSecond(3) As Integer
'Dim arThird(3) As Integer
'Dim arFourth(3) As Integer
'arFirst(0) = 1
'arFirst(1) = 2
'arFirst(2) = 3
'arFirst(3) = 4
'
'arSecond(0) = 1
'arSecond(1) = 2
'arSecond(2) = 3
'arSecond(3) = 4
'
'arThird(0) = 1
'arThird(1) = 2
'arThird(2) = 3
'arThird(3) = 4
'
'arFourth(0) = 1
'arFourth(1) = 2
'arFourth(2) = 3
'arFourth(3) = 4
intBetCount = 0
For intCountFirst = 0 To UBound(arFirst)
For intCountSecond = 0 To UBound(arSecond)
For intCountThird = 0 To UBound(arThird)
For intCountFourth = 0 To UBound(arFourth)
If (arFirst(intCountFirst) <> arSecond(intCountSecond)) And (arFirst(intCountFirst) <> arThird(intCountThird)) And (arFirst(intCountFirst) <> arFourth(intCountFourth)) Then
If (arSecond(intCountSecond) <> arThird(intCountThird)) And (arSecond(intCountSecond) <> arFourth(intCountFourth)) Then
If (arThird(intCountThird) <> arFourth(intCountFourth)) Then
' Debug.Print "First " & arFirst(intCountFirst), " Second " & arSecond(intCountSecond), "Third " & arThird(intCountThird), " Fourth " & arFourth(intCountFourth)
intBetCount = intBetCount + 1
End If
End If
End If
Next intCountFourth
Next intCountThird
Next intCountSecond
Next intCountFirst
fnFirst4PermCount = intBetCount
End Function
this function takes four string arrays for each position. I left in test code (commented out) so you can see how it works for 1/2/3/4 for each of the four positions

Resources