ASP/VB: Counting and ordering array values - asp.net

I am new to writing in asp and vb and am stuck on a piece of logic where I need to retrieve data from a web form, count the number of entries and then order them alphanumerically.
I have a webform with the multiple text boxes that can be filled out and submitted that looks a little like this: (excuse the spreadsheet, it's a visual aid only)
I have made an array that contains their values like this:
myArray = array(town, medal, record, sport)
I would like to count and order (everything alphanumerically) the total medals, how many of each medal each town won and the number of records set by each town.
My psuedocode looks a little like this, hopefully I am a little on the right track in terms of logic. The main area I am a little short in is knowing what statements would be good and where, especially to order them alphanumerically.
'this is the psuedocode for the total medals per town
tally = 0 'Set tally to 0
for myArray(town) 'For each town
for myArray(medal) 'For each medal
tally = tally + 1 'Add 1 to the total tally
response.write(myArray(town) "has" tally "medals" & "<br>")
next
next
'this is the pseudocode for the individual medals
for myArray(town) 'For each town
for myArray(medal) 'For each medal
goldTally = 0
silverTally = 0
bronzeTally = 0
if medal = "G"
goldTally = goldTally + 1
elseif medal = "S"
silverTally = silverTally + 1
else medal = "B"
bronzeTally = bronzeTally + 1
response.write(myArray(town) "has:" goldTally "gold medals" &"<br>"
silverTally "silver medals" &"<br>"
bronzeTally "bronze medals" &"<br>"
next
next
Any help you can give would be greatly appreciated thanks heaps.

The VBScript tool for counting/grouping/classifying is the Dictionary. Some use cases: Set ops, word list, split file.
Simple Arrays can be sorted via using an ArrayList. [Array vs Arraylist], fancy sorting7.
For tabular data, use a disconnected recordset.
Inline demo:
Option Explicit
' simple sample data
Dim a : a = Split("b c a b b c a a b")
' use a dictionary for counting/grouping
Dim d : Set d = CreateObject("Scripting.Dictionary")
Dim e
For Each e In a
d(e) = d(e) + 1
Next
WScript.Echo Join(d.Keys)
WScript.Echo Join(d.Items)
' use an ArrayList for sorting simple arrays
Dim l : Set l = CreateObject("System.Collections.ArrayList")
For Each e in a
l.Add e
Next
l.Sort
WScript.Echo Join(l.ToArray())
' use a disconnected recordset for tabular data
Const adVarChar = 200
Const adInteger = 2
Const adClipString = 2
Dim r : Set r = CreateObject("ADODB.Recordset")
r.Fields.Append "k", adVarChar, 50
r.Fields.Append "n", adInteger
r.Open
For Each e In d.Keys
r.AddNew
r.Fields("k").value = e
r.Fields("n").value = d(e)
r.Update
Next
r.MoveFirst
Do Until r.EOF
WScript.Echo r.Fields("k").value, r.Fields("n").value
r.MoveNext
Loop
r.Sort = "k DESC"
WScript.Echo r.GetString(adClipString, , ", ", "; ", "null")
output:
cscript 39305170.vbs
b c a
4 2 3
a a a b b b b c c
a 3
c, 2; b, 4; a, 3;
BTW: Even in a pseudo code language,
for myArray(town) 'For each town
and
response.write(myArray(town) "has:" goldTally "gold medals" ...
can't work at the same time.

Related

Iterating through a data set and merging specific pairs of rows where data is null in R or excel

I have a data set with several hundred rows. Most rows have complete information, but in some cases two rows share the same key while some attributes are repeated, others are not. Here is an example:
Key Campaign Message Stat1 Stat2 Stat3 Stat4
123 Fun yay 1 2
123 temp yay 3 4
Intended result
123 Fun yay 1 2 3 4
Issues:
Needs to search the entire dataframe of hundreds of records, most of which are not duplicates. Ignore the non-duplicates
Has to specify that when combining rows to accept the Campaign data that is NOT "temp"
All other columns where data matches is ok
Columns where one value is null will result in the non-null value being used in the new record
I am open to solutions in R, SQL or excel (vba)
Appreciate any help!
Turned out to be a bit more involved than I thought, but here it is. I am using a collection to merge duplicate keys. Change IGNORE_TEMP constant to include or exclude temp records.
Sub mergeNonNulls()
' change this constant to ignore or include temp results
Const IGNORE_TEMP As Boolean = True
' temporary store of merged rows
Dim cMerged As New Collection
' data part of the table
Dim data As Range
Set data = ActiveSheet.[a2:g3]
Dim rw As Range ' current row
Dim r As Range ' temporary row
Dim c As Range ' temporary cell
Dim key As String
Dim arr() As Variant
Dim v As Variant
Dim vv As Variant
Dim i As Long
Dim isChanged As Boolean
For Each rw In data.Rows
key = rw.Cells(1) ' the first column is key
If IGNORE_TEMP And rw.Cells(2) = "temp" Then
DoEvents ' pass temp if enabled
Else
If Not contains(cMerged, key) Then
' if this is new key, just add it
arr = rw
cMerged.Add arr, key
Else
' if key exists - extract, merge nulls and replace
arr = cMerged(key)
' iterate through cells in current and stored rows,
' identify blanks and merge data if current is empty
i = 1
isChanged = False
For Each c In rw.Cells
If Len(Trim(arr(1, i))) = 0 And Len(Trim(c)) > 0 Then
arr(1, i) = c
isChanged = True
End If
i = i + 1
Next
' collections in vba are immutable, so if temp row
' was changed, replace it in collection
If isChanged Then
cMerged.Remove key
cMerged.Add arr, key
End If
End If
End If
Next
' output the result
Dim rn As Long: rn = 1 ' output row
Dim numRows As Long
Dim numCols As Long
With ActiveSheet.[a6] ' output start range
For Each v In cMerged
numRows = UBound(v, 1) - LBound(v, 1) + 1
numCols = UBound(v, 2) - LBound(v, 2) + 1
.Cells(rn, 1).Resize(numRows, numCols).Value = v
rn = rn + 1
Next
End With
End Sub
' function that checks if the key exists in a collection
Function contains(col As Collection, key As String) As Boolean
On Error Resume Next
col.Item key
contains = (Err.Number = 0)
On Error GoTo 0
End Function

Function to generate random list of words which are 8 characters long

I am using Classic ASP, and have a MySQL table ("j_un2") with 6,318 random words in, the total count there will never change. The IDs in the table are gapless.
I need to generate a list of 5 random concatenated strings made up of 2 words, where the total length of the string is 8 characters long.
I already got some very useful help a few days ago via:
Selecting random words from table
Optimising SQL to concatenate random words
Based on the help I received, I wrote this simple function to generate 8 character random word combinations:
<%
Function f1(str)
found = "no"
do while found <> "yes"
rand1 = Int((Rnd * 6138) + 1)
rand2 = Int((Rnd * 6138) + 1)
SQL = "SELECT CONCAT(w1.fld_un, w2.fld_un) word FROM j_un2 w1 , j_un2 w2 WHERE w1.fld_id = "&rand1&" AND w2.fld_id = "&rand2&""
set pRS = oConn.Execute(SQL)
word = pRS("word")
if len(word) = str then
found = "yes"
f1 = word
end if
Loop
End Function
for i = 1 to 5
bob = f1(8)
response.write bob & "<br />"
next
%>
It works pretty quickly, runs in less than 1 second, which is great.
However, the words it generates are always in the same order - e.g.
digpills
grincost
grownjaw
jonesbin
cloudme
If I refresh the page, it generates the words in the same order. I know that there are many hundreds of words in the table which will combine to make an eight character long string, so it's not that there aren't enough words in the database.
If I do e.g. this:
for i = 1 to 5
bob = f1(8)
response.write bob & "<br />"
next
for i = 1 to 5
bob = f1(8)
response.write bob & "<br />"
next
for i = 1 to 5
bob = f1(8)
response.write bob & "<br />"
next
for i = 1 to 5
bob = f1(8)
response.write bob & "<br />"
next
Then it will generate 20 random 8 character long combinations, but again, those 20 are always in the same order.
I am not a very smart programmer - am I missing something, as I can't work out how to get a completely random list each time I refresh the page.
You need to use "Randomize" to get different numbers for your ID's every time.
Dim max,min
max=100
min=1
Randomize
response.write(Int((max-min+1)*Rnd+min))
More about it here

How to add to an array from within a function in VBScript?

I'm having trouble writing a function that will output an array of records. What I am attempting to do is call a function that gets all the records in a table and will create a multi-dimensional array that I can use in the page that calls the function.
Can you tell me what I'm doing wrong?
function get_admins
set rs = Server.CreateObject("ADODB.recordset")
rs.cursorType = 3
getsql = "select * from users order by name asc"
rs.Open getsql, conn
total = rs.RecordCount
ra = array
c = 0
if total < 1 then
o = "There are no admins yet."
else
do until rs.EOF
id = rs.Fields("id").value
username = rs.Fields("username").value
adminname = rs.Fields("name").value
email = rs.Fields("email").value
Redim Preserve ra(c,4) '<-- This is the line the error doesn't like
ra(c,0) = id
ra(c,1) = username
ra(c,2) = adminname
ra(c,3) = email
c = c + 1
rs.MoveNext
loop
end if
rs.close
get_admins = ra
end function
This is the error I get:
Microsoft VBScript runtime error '800a0009'
Subscript out of range
Function call on the page looks like this:
<pre><%
dim seeme
set seeme = get_admins
%></pre>
Here are some similar questions I found:
Classic ASP 3.0 Create Array from a Recordset - Helped a lot, but not quite there.
Redim Preserve gives 'subscript out of range' - This one just straight confused me.
ReDim Preserve can only change the size of the last dimension in multidimensional arrays, so it's not really useful in your situation. What you can use is an array of arrays, though:
ReDim ra(-1) 'initialize record array as empty array
...
Else
Do Until rs.EOF
ReDim va(3) 'initialize value array (clear values)
va(0) = rs.Fields("id").value
va(1) = rs.Fields("username").value
va(2) = rs.Fields("name").value
va(3) = rs.Fields("email").value
Redim Preserve ra(UBound(ra)+1) 'grow record array
ra(UBound(ra)) = va 'put value array into record array
rs.MoveNext
Loop
End If
That will allow you to access the elements of the nested arrays like this:
WScript.Echo ra(3)(1)
The above will print the 2nd value (index 1) from the 4th nested array (index 3).
As for returning the array, you cannot use the Set keyword in the assignment:
set seeme = get_admins '<-- will fail!
That's because that keyword is reserved for object assignments and arrays aren't objects. Change that line to this:
seeme = get_admins
Instead of rolling your own, look at the .GetRows method.
To put some code behind my claim:
Dim oTCN : Set oTCN = CreateObject( "ADODB.Connection" )
Dim sTDir : sTDir = "M:\lib\kurs0705\testdata\txt" ' <-- ohne \ am Ende!
Dim sCS : sCS = Join( Array( _
"Provider=MSDASQL" _
, "Driver={Microsoft Text Driver (*.txt; *.csv)}" _
, "DBQ=" & sTDir _
), ";" )
oTCN.Open sCS
Dim oRS
Set oRS = oTCN.Execute("SELECT TOP 3 * FROM [gendata.txt]")
Dim nUB : nUB = oRS.Fields.Count - 1
ReDim aRow(nUB) ' array for one row
ReDim aRows(nUB, -1) ' 2nd dim growable array for all rows
Dim f
For f = 0 To UBound(aRow)
aRow(f) = oRS.Fields(f).Name
Next
WScript.Echo Join(aRow, ",")
Do Until oRS.EOF
ReDim Preserve aRows(nUB, UBound(aRows, 2) + 1)
For f = 0 To UBound(aRow)
aRow(f) = oRS.Fields(f).Value
aRows(f, UBound(aRows, 2)) = oRS.Fields(f).Value
Next
WScript.Echo Join(aRow, ",")
oRS.MoveNext
Loop
oRS.MoveFirst
Dim aMagic : aMagic = oRS.GetRows() ' this is all you need!
Dim r, c
For r = 0 To UBound(aMagic, 2)
For c = 0 To UBound(aMagic, 1)
WScript.Echo r, c, aMagic(c, r), aRows(c, r)
Next
WScript.Echo
Next
oTCN.Close
output:
=============================================================
iID,sFrsName,sLstName,sSex,dtBirth
1,Yqiqpbcmunrzvi,Pmyqcxfoffrfnwbd,U,8/7/2008
2,Viyvfshpxu,Xjtfbjuiiwojhyjwkefcu,U,7/27/2008
3,Hoocyseiiiawrt,Mrpuhzuhysslzhwhnpp,F,8/7/2008
0 0 1 1
0 1 Yqiqpbcmunrzvi Yqiqpbcmunrzvi
0 2 Pmyqcxfoffrfnwbd Pmyqcxfoffrfnwbd
0 3 U U
0 4 07.08.2008 07.08.2008
1 0 2 2
1 1 Viyvfshpxu Viyvfshpxu
1 2 Xjtfbjuiiwojhyjwkefcu Xjtfbjuiiwojhyjwkefcu
1 3 U U
1 4 27.07.2008 27.07.2008
2 0 3 3
2 1 Hoocyseiiiawrt Hoocyseiiiawrt
2 2 Mrpuhzuhysslzhwhnpp Mrpuhzuhysslzhwhnpp
2 3 F F
2 4 07.08.2008 07.08.2008
=============================================================
So - contrary to Ansgar's "You can't use ReDim Preserve on multidimensional arrays" - you can grow the last dimension of an multidimensional array. That means you have to grow the rows and layout your array in a col/row instead of the more 'natural' row/col structure.
aRows shows how you roll your own .GetRows correctly. Of course the sane strategy is to use, as in
Dim aMagic : aMagic = oRS.GetRows() ' this is all you need!

Creating a 2d stacked column chart with priority

What I'm trying to do is create a 2d stacked chart where the position of my series means something like where they are in a queue (position 1 - being the upermost section of the stacked column is last to get served and position 2- is the bottom section of the stacked column will be first up).
I've formatted my data to looks like this (but this can be easily changed if the solution needs it to be):
Task 1 Task 2 Task 3 <- x-axis
A 100 B 400 B 510 <- This row is position 1
B 200 A 200 A 300 <- This row is position 2
^-Legend
The issue I'm having is that I want all tasks on the same chart and excel isn't recognizing at every x the position of A and B. It simply is assuming from Column 1 that Row 2 is A and Row 3 is B and is not adjusting in each subsequent column based on the A/B keys. I'm wondering if there's a way to do this.
As a recap, is it possible to get a 2d stacked chart with multiple x-values that recognizes the position of your legend keys (whether it should be at the top or bottom of the column) at each unique x-value. Any solution either VBA or in-sheet formula I haven't had any luck with.Thanks in advance.
'Run this macro from the sheet containing your data, after highlightling the data.
Sub Macro3()
'The below code assumes that you have already selected
'the columns containing your data and that the first column,
'and every 2nd column after that contains your legend keys.
Dim rng As Range
Set rng = Selection
Dim colNum As Integer
Dim rowNum As Integer
Dim strLegend As String
Dim rowStart As Integer
Dim colStart As Integer
Dim strSeries As String
Dim i As Integer
Dim seriesNum As Integer
Dim shtName As String
rowStart = rng.Row
colStart = rng.Column
shtName = ActiveSheet.Name & "!"
'Creates an empty chart...
ActiveSheet.Shapes.AddChart.Select
'...of type StackedColumn.
ActiveChart.ChartType = xlColumnStacked
seriesNum = 0
'Select all the cells that match the legend in the first column.
For rowNum = 0 To rng.Rows.Count - 1
strLegend = Cells(rowStart + rowNum, colStart).Value
strSeries = "=" & shtName & Cells(rowStart + rowNum, colStart + 1).Address
For colNum = 2 To rng.Columns.Count - 1 Step 2
For i = 0 To rng.Rows.Count - 1
If Cells(rowStart + i, colStart + colNum).Value = strLegend Then
strSeries = strSeries & "," & shtName & Cells(rowStart + i, colStart + colNum + 1).Address
Exit For
End If
Next
Next
'Create a new series.
ActiveChart.SeriesCollection.NewSeries
seriesNum = seriesNum + 1
'Set the legend.
ActiveChart.SeriesCollection(seriesNum).Name = strLegend
'Set the X axis labels to nothing, so the default is used.
ActiveChart.SeriesCollection(seriesNum).XValues = ""
'Set the series data.
ActiveChart.SeriesCollection(seriesNum).Values = strSeries
Next
'An extra series gets added automatically???
'This code removes it.
If ActiveChart.SeriesCollection.Count > rng.Rows.Count Then
ActiveChart.SeriesCollection(rng.Rows.Count + 1).Delete
End If
End Sub
This code requires that your legend values and number values each be in separate columns like shown below. The labels 'Task 1', etc. are not used in this example.
A | 100 | B | 400 | B | 510
B | 200 | A | 200 | A | 300

Further problems with counting occurrences of strings in an Array

I am copying a question and answer from elsewhere as it partly goes into what I need but not completely.
In ASP classic, is there a way to count the number of times a string appears in an array of strings and output them based on string and occurrence count?
For example if I have an array which contains the following :
hello
happy
hello
hello
testing
hello
test
happy
The output would be:
hello 4
happy 2
test 1
testing 1
The answer that was given was this:
I'm assuming the language is VBScript (since that's what most people use with classic ASP).
You can use a Dictionary object to keep track of the individual counts:
Function CountValues(pArray)
Dim i, item
Dim dictCounts
Set dictCounts = Server.CreateObject("Scripting.Dictionary")
For i = LBound(pArray) To UBound(pArray)
item = pArray(i)
If Not dictCounts.Exists(item) Then
dictCounts.Add item, 0
End If
dictCounts.Item(item) = dictCounts.Item(item) + 1
Next
Set CountValues = dictCounts
End Function
This is great but I can't work out how to grab the top 2 most used words, display them and be able to put them in their own variable for use elsewhere.
Can anyone help with this?
You can loop through the dictionary object using this method. Inside that loop keep track of the top two keys and their counts in either a new array or two new variables.
You can't sort a Dictionary object in VBScript, so you have to use something else.
My advice is using a disconnected Recordset object to hold the items and their occurrences. Such object natively support sorting and it's pretty easy to use. To achieve this have such function instead:
Function CountValues_Recordset(pArray)
Dim i, item
Dim oRS
Const adVarChar = 200
Const adInteger = 3
Set oRS = CreateObject("ADODB.Recordset")
oRS.Fields.Append "Item", adVarChar, 255
oRS.Fields.Append "Occurrences", adInteger, 255
oRS.Open
For i = LBound(pArray) To UBound(pArray)
item = pArray(i)
oRS.Filter = "Item='" & Replace(item, "'", "''") & "'"
If (oRS.EOF) Then
oRS.AddNew
oRS.Fields("Item").Value = item
oRS.Fields("Occurrences").Value = 1
Else
oRS.Fields("Occurrences").Value = oRS.Fields("Occurrences").Value + 1
End If
oRS.Update
oRS.Filter = ""
Next
oRS.Sort = "Occurrences DESC"
oRS.MoveFirst
Set CountValues_Recordset = oRS
End Function
And using it to achieve the output you want:
Dim myArray, oRS
myArray = Array("happy", "hello", "hello", "testing", "hello", "test", "hello", "happy")
Set oRS = CountValues_Recordset(myArray)
Do Until oRS.EOF
Response.Write(oRS("item") & " " & oRS("Occurrences") & "<br />")
oRS.MoveNext
Loop
oRS.Close
Set oRS = Nothing
Don't forget to close and dispose the recordset after using it.

Resources