Users select desired options through use of a checkbox. The caption values of each check box are stored in a dynamic array then displayed in message box confirming the selections.
I now need to loop through a range of cells, at every row determining if cell (x,4) is equal to any value in the array, but I don't know how to loop like that. See code below where the array is populated.
Thank you in advance!
Sub ProcessStrats_Click()
Dim ctl As Control
Dim cnt As Long
Dim msg As String
Dim i As Long
Dim cResp As Integer
Dim stArray() As Variant
cnt = 0 'Initialize counter outside of loop
For Each ctl In StratFill.Controls 'look at every control in StratForm box
If Left(ctl.Name, 8) = "CheckBox" Then 'if the control is named 'checkbox' then
If ctl.Value = True Then 'if the control is marked as 'true' i.e. checked, then
ReDim Preserve stArray(0 To cnt) 'Reset the array dimension on each iteration of loop
stArray(cnt) = ctl.Caption 'Add value in value of checkbox caption to Array
cnt = cnt + 1 'Advance the counter to next array item
End If
End If
Next
Unload StratFill 'unload and close stratfill form
msg = "The following strategies will be priced:" & vbNewLine & vbNewLine
For i = LBound(stArray) To UBound(stArray) 'loops through all values of array
msg = msg & stArray(i) & vbCR 'strings together displayed txt
Next i
If MsgBox(msg, vbYesNo, "Confirm Strategies") = vbYes Then
'if yes is clicked
Call RunPricing '"RunPricing" will run
Else 'if no is clicked
StratFill.Show 'then the strategy selector box will display again
End If
End Sub
Try this:
For i = 1 To UBound(stArray) 'loops through all values of array
Range("$D2:" & Range("D" & Rows.Count).End(xlUp).Address).Select
Selection.Find(What:=stArray(i), After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Offset(0, 2).Select
msg = msg & stArray(i) & ActiveCell.Value & vbCR 'strings together displayed txt
Next i
Related
Every morning I have to compare manually row by row the information in my database with the one sent by the broker. Normally they should have exactly the same information.
The information is about executed trades.
1- I need to compare row by row looking at the values "Stock", "Qty", "Price" and "Date". If any row is not matched from each other (i.e. a value is erroneously different in one of the table or the entire row is missing), I need the unmatched rows to be printed in a third "OUTPUT" table.
My TABLE, BROKER'S TABLE & OUTPUT
2- The thing here is that there are duplicates like for "microsoft" or "nvidia" that are independent trades (different IDs). Duplicates must be kept in the comparison because they are different trades.
How could I manage the duplicates problems? Using Collections in Dictionary could help me? I would compare Table A to Table B and then Table B to Table A.
Or the presence of duplicates (actually independent trades) makes it impossible to perform ?
My file has more than 500 rows.
I'll add an entirely in-memory way to achieve the output.
The one thing worth considering is that we have no way of differentiating one ID from the next if they have matching stock, price, qty, and dates. So, the way I'm handling duplicates is in the order that they appear in the spreadsheet. So if there are two matching entries in your table, and only 1 in the broker table, I assume that the first entry in your table matches the first entry in the broker table, and therefore your second entry will be output.
Try working through the code. I took a few shortcuts for the sake of timing, but I also encapsulated each of the functions so that you can modify as needed. You'll just have to build out the DeserializeKey function to convert a key back to cells in the output sheet (shouldn't be too hard). See the below code, and let me know if it meets expectations.
Note: You will run the "CompareDictionaries" subroutine. The others are helper functions.
Sub CompareDictionaries()
Dim oMine As Object
Dim oBroker As Object
Dim myQueueCount As Long
Dim brokerQueueCount As Long
Dim minQueue As Long
Dim oMinQueue As Object
Set oMine = GetDictionary(Sheet1.Range("A2:E7"))
Set oBroker = GetDictionary(Sheet2.Range("A2:E6"))
For Each oKey In oMine.keys
'The whole row does not exist in the broker table
If Not oBroker.Exists(oKey) Then
Do While oMine(oKey).Count > 0
DeserializeKey oKey, oMine(oKey).dequeue
Loop
Else 'The keys exist in both tables
myQueueCount = oMine(oKey).Count
brokerQueueCount = oBroker(oKey).Count
If myQueueCount = brokerQueueCount Then
'Do nothing. They both have the same number of
'id's, and so we assume they are in sync.
Else
'Determine the minimum queue size, and get rid
'of that many values, since we won't need them
minQueue = IIf(myQueueCount < brokerQueueCount, myQueueCount, brokerQueueCount)
For i = 1 To minQueue
oMine(oKey).dequeue
oBroker(oKey).dequeue
Next i
'Take the remaining IDs out of the dictionary/queue that had more
If brokerQueueCount > myQueueCount Then
Set oMinQueue = oBroker
Else
Set oMinQueue = oMine
End If
Do While oMinQueue(oKey).Count > 0
DeserializeKey oKey, oMinQueue(oKey).dequeue
Loop
End If
End If
Next oKey
'The only remaining thing to test for is keys in the broker dict
'that are not in the myDict
For Each oKey In oBroker.keys
If Not oMine.Exists(oKey) Then
Do While oBroker(oKey).Count > 0
DeserializeKey oKey, oBroker(oKey).dequeue
Loop
End If
Next oKey
End Sub
Function GetDictionary(inputRange As Range) As Object
Dim oDict As Object
Dim sht As Worksheet
Dim cel As Range
Dim theKey As String
Dim oQueue As Object
Set sht = inputRange.Parent
Set oDict = CreateObject("Scripting.Dictionary")
For Each cel In Intersect(inputRange, sht.Columns(1))
theKey = GenerateKey(cel.Resize(, 5))
If oDict.Exists(theKey) Then
oDict(theKey).enqueue cel.Value
Else
Set oQueue = CreateObject("System.Collections.Queue")
oQueue.enqueue cel.Value
oDict.Add theKey, oQueue
End If
Next cel
Set GetDictionary = oDict
End Function
Sub DeserializeKey(ByVal theKey As String, theId As String)
'This is where you'd do some stuff to
'turn the key into individual cells, and store it.
'I'm only writing to the debug widnow to demonstrate
Debug.Print theId & " " & theKey
End Sub
Function GenerateKey(rng As Range) As String
GenerateKey = rng(2) & Format(rng(3), "0") _
& Format(rng(4), "0.00") & Format(rng(5), "mmddyyyy")
End Function
For those interested in this method, I'm editing this answer to add the "deserializekey" function:
Dim r As Long
Worksheets("Output").Activate
r = 1
'What we are doing here with "loopcell" is to check if the destination cells in the "output" sheet are empty or free.
'If not, we go down 1 row.
loopcell:
If IsEmpty(Range("A" & r).Value) = True Then
Range("A" & r).Value = "_" & theId & "_" & theKey
Else
r = r + 1
GoTo loopcell
End If
'The key is wrote to the the cell but we need to split every element of the key in multiple cells.
splitOutput = Range("A" & r).Value
splitArray = Split(splitOutput, "_")
For i = 1 To UBound(splitArray)
Cells(r, i).Value = splitArray(i)
Next i
Debug.Print theId & " " & theKey
End Sub ```
** New GetDictionary and Deserialize methods used to store more info **
Sub DeserializeKey(ByVal theKey As String, theId As Variant)
'This is where you'd do some stuff to
'turn the key into individual cells, and store it.
'I'm only writing to the debug widnow to demonstrate
Dim output As String
'Keep in mind that we have a 2d array, and we are reading
'one row at a time. So get the number of columns in the
'array, and then do whatever you need with them.
For i = LBound(theId, 2) To UBound(theId, 2)
output = output & " " & theId(1, i)
Next i
Debug.Print theKey & " -->" & output
End Sub
Function GetDictionary(inputRange As Range) As Object
Dim oDict As Object
Dim sht As Worksheet
Dim cel As Range
Dim theKey As String
Dim oQueue As Object
Dim columnCount As Long
Dim rngAsArray As Variant
Set sht = inputRange.Parent
'Get the column count of the input range. Since we don't
'hardcode it in, this function is more flexible to
'future changes
columnCount = inputRange.Columns.Count
Set oDict = CreateObject("Scripting.Dictionary")
For Each cel In Intersect(inputRange, sht.Columns(1))
theKey = GenerateKey(cel.Resize(, 5))
'Put the full row into an array, which we will then
'store as the content of the queue
rngAsArray = cel.Resize(, columnCount).Value
If oDict.Exists(theKey) Then
oDict(theKey).enqueue rngAsArray
Else
Set oQueue = CreateObject("System.Collections.Queue")
oQueue.enqueue rngAsArray
oDict.Add theKey, oQueue
End If
Next cel
Set GetDictionary = oDict
End Function
First of all, please read DS_London's comment.
If you would like to have a result sheet, then you can use below macro:
Option Explicit
Sub CompareData()
Dim wbk As Workbook
Dim wshMyData As Worksheet, wshBrokersData As Worksheet, wshResult As Worksheet
Dim i As Integer, j As Integer, k As Integer
Dim sTmp As String
On Error Resume Next
Set wbk = ThisWorkbook
Set wshResult = wbk.Worksheets("Result")
On Error GoTo Err_CompareData
'if there_s no result sheet
If Not wshResult Is Nothing Then
Application.DisplayAlerts = False
wbk.Worksheets("Result").Delete
Application.DisplayAlerts = True
End If
Set wshMyData = wbk.Worksheets("Sheet1")
Set wshBrokersData = wbk.Worksheets("Sheet2")
Set wshResult = wbk.Worksheets.Add(After:=wshBrokersData)
wshResult.Name = "Result"
wshResult.Range("A1") = "ID"
wshResult.Range("B1") = "Stock"
wshResult.Range("C1") = "Qty"
wshResult.Range("D1") = "Price"
wshResult.Range("E1") = "Date"
wshResult.Range("F1") = "My"
wshResult.Range("G1") = "Broker"
wshResult.Range("A1:G1").Interior.Color = vbGreen
'find last entry in your data
i = wshMyData.Range("A" & wshMyData.Rows.Count).End(xlUp).Row
'find last entry in brokers data
j = wshBrokersData.Range("A" & wshBrokersData.Rows.Count).End(xlUp).Row
'copy data into result sheet
k = 2
wshMyData.Range("A2:E" & i).Copy wshResult.Range("A" & k)
k = k + i - 1
wshBrokersData.Range("A2:E" & j).Copy wshResult.Range("A" & k)
k = k + j - 2
'remove duplicates
wshResult.Range("$A$1:$E$" & k).RemoveDuplicates Columns:=Array(2, 3, 4, 5), Header:=xlYes
k = wshResult.Range("A" & wshResult.Rows.Count).End(xlUp).Row
'start comparison ;)
'my data
sTmp = "(" & wshMyData.Name & "!" & wshMyData.Range("B1:B" & i).AddressLocal & "=B2)"
sTmp = sTmp & "*(" & wshMyData.Name & "!" & wshMyData.Range("C1:C" & i).AddressLocal & "=C2)"
sTmp = sTmp & "*(" & wshMyData.Name & "!" & wshMyData.Range("D1:D" & i).AddressLocal & "=D2)"
sTmp = sTmp & "*(" & wshMyData.Name & "!" & wshMyData.Range("E1:E" & i).AddressLocal & "=E2)"
sTmp = "=SUM(IF(" & sTmp & ", 1, 0))"
wshResult.Range("F2").BorderAround LineStyle:=xlContinuous
wshResult.Range("F2").FormulaArray = sTmp
wshResult.Range("F2:F" & k).FillDown
'brokres data
sTmp = "(" & wshBrokersData.Name & "!" & wshBrokersData.Range("B1:B" & i).AddressLocal & "=B2)"
sTmp = sTmp & "*(" & wshBrokersData.Name & "!" & wshBrokersData.Range("C1:C" & i).AddressLocal & "=C2)"
sTmp = sTmp & "*(" & wshBrokersData.Name & "!" & wshBrokersData.Range("D1:D" & i).AddressLocal & "=D2)"
sTmp = sTmp & "*(" & wshBrokersData.Name & "!" & wshBrokersData.Range("E1:E" & i).AddressLocal & "=E2)"
sTmp = "=SUM(IF(" & sTmp & ", 1, 0))"
wshResult.Range("G2").BorderAround LineStyle:=xlContinuous
wshResult.Range("G2").FormulaArray = sTmp
wshResult.Range("G2:G" & k).FillDown
'autofit
wshResult.Range("A:G").Columns.AutoFit
Exit_CompareData:
On Error Resume Next
Set wshMyData = Nothing
Set wshBrokersData = Nothing
Set wshResult = Nothing
Set wbk = Nothing
Exit Sub
Err_CompareData:
MsgBox Err.Description, vbExclamation, Err.Number
Resume Exit_CompareData
End Sub
Result:
As you can see, 0 means that there's no corresponding data in selected sheet.
What above macro does?
Adds new sheet: Result, then adds column headers (ID, Stock, Qty, Price, Date, My data, Broker in row 1 respectively in columns A-G)
Copies all data from your sheet (Sheet1) to Result sheet
Copies all data from broker's sheet (Sheet2) to Result sheet
Removes duplicates in Result sheet (based on all columns excluding ID)
Inserts formula-array in cell F2 and G2 and fill it down.
Important note: There's at least few other ways to achieve that...
Final note: Feel free to change the code to your needs.
I currently have code set up that will loop through all the worksheets in my workbook, paste a date in a cell which, when non blank, will have the remaining cells in the row populate with data.
At the beginning of each row - I have a formula that will say "Error" if any of the cells in that row has an error in it. like this:
I then have another loop which will go back through each worksheet and check to see if there is an error in that cell and if so, will go to the first sheet in the workbook to a specific cell and add "Error on xyz Tab". If there are multiple errors, it'll go to the next row down and paste it. So it looks like this:
I'm thinking instead of looping through each sheet again, could i store the text string in a variable/array and just paste it on the front sheet at the end of the loop in the same manner?
This is the code for the error loop that's currently set up:
For I = 1 To WS_Count
ActiveWorkbook.Worksheets(I).Activate
Cells.Find(What:="Date", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).End(xlDown).Offset(0, -1).Activate
If ActiveCell.Value = "Error" Then
Application.Goto "ErrorCheck"
If ActiveCell.Offset(1, 0).Value = vbNullString Then
ActiveCell.Offset(1, 0).Value = "Error on " & ActiveWorkbook.Worksheets(I).Name & " " & Hour(Now) & "00"
Else
Selection.End(xlDown).Activate
ActiveCell.Offset(1, 0).Value = "Error on " & ActiveWorkbook.Worksheets(I).Name & " " & Hour(Now) & "00"
End If
Else
End If
Next I
So with this I personally wouldn't want to use an array. I would prefer using a collection. It is easier because you do not know the parameters for your array so it is tough to give it dimensions.
Nonetheless find below a possible solution. Work it to your needs. I have yet to test or debug myself. But should do the trick.
Sub ErrorCheck()
Dim x As Long, lRow1 As Long, lRow2 As Long
Dim myCollection As New Collection
Dim ws As Worksheet
Dim mySheet As Worksheet
Set mySheet = Sheets("ErrorCheckSheet")
'create the for loop to cycle through worksheets
For Each ws In ThisWorkbook.Worksheets
'set the lrow to iterate through column
'set the colum for your need - "Error" column
lRow1 = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
'IF lRow does not match your cell, use a static variable ie. 50
'assuming your data starts in row 2 as per picture
For x = 2 To lRow1
'check each cell for error text
If ws.Range("A" & x).Text = "Error" Then
'when found add to collection
'adjust to meet your cell you want to input into collection
myCollection.Add ws.Range("B" & x).Text
End If
Next x
Next ws
'once you have completely cycled through your workbook your collection will now be loaded
For x = 1 To myCollection.Count
'set the lrow on the sheet you want to enter the data in
lRow2 = mySheet.Range("U" & mySheet.Rows.Count).End(xlUp).Row + 1
'now set the variable
mySheet.Range("U" & lRow2).Value = "Error on" & myCollection(x)
Next x
Set myCollection = New Collection
Set mySheet = Nothing
End Sub
I am trying to delete Multiple columns from Multiple sheets while retaining those found in a list.
For example I have sheet1, sheet2, sheet3, ..., sheet7.
From these sheets I have particular columns to be keep like.
From sheet1 I want keep columns like s.no, cust.name, product, date remaining all should be deleted same from sheet2 I want to keep prod.disc,address, pin remaining all should be deleted like I have remaining sheets in that I want to keep particular columns remaining all should be deleted.
I am trying to do using arrays but not able start how to do. I have basic syntax.
Sub sbVBS_To_Delete_Specific_Multiple_Columns()
Sheets("Sheet1").Range("A:A,C:C,H:H,K:O,Q:U").EntireColumn.Delete
End Sub`[code]
But that didn't work for me because in future some columns may add in it and I want columns should recognize with name which column to keep and remaining to discard.
OK, here is the basic code. Specify the worksheet and the columns to be deleted in the main procedure. Set the row in which to find the captions in the sub-procedure.
Sub DeleteColumns()
' 17 Mar 2017
Dim ClmCaption As Variant
Dim Ws As Worksheet
Dim i As Integer
Set Ws = ActiveSheet
' better to specify the sheet by name, like Set Ws = ThisWorkbook.Worksheets("My Excel")
Application.ScreenUpdating = False ' freeze screen (speeds up execution)
ClmCaption = Array("One", "two", "three", "four", "five")
' specify all the columns you want to delete by caption , not case sensitive
For i = 0 To UBound(ClmCaption) ' loop through all the captions
DelColumn Ws, CStr(ClmCaption(i)) ' call the sub for each caption
Next i
Application.ScreenUpdating = True ' update screen
End Sub
Private Sub DelColumn(Ws As Worksheet, Cap As String)
' 17 Mar 2017
Dim CapRow As Long
Dim Fnd As Range
CapRow = 3 ' this is the row where the captions are
Set Fnd = Ws.Rows(CapRow).Find(Cap) ' find the caption
If Fnd Is Nothing Then
MsgBox "The caption """ & Cap & """ doesn't exist." & vbCr & _
"The column wasn't deleted.", _
vbInformation, "Invalid parameter"
Else
Ws.Columns(Fnd.Column).EntireColumn.Delete Shift:=xlToLeft
End If
End Sub
You can run the code as it is but you will get a lot of error messages because the specified captions don't exist.
The following uses a Scripting Dictionary object that maintains a list of worksheets to be processed as the dictionary keys with an array of column header labels to keep as the associated items.
Option Explicit
Sub delColumnsNotInDictionary()
Dim d As Long, ky As Variant, dict As Object
Dim c As Long, lc As Long
Set dict = CreateObject("Scripting.Dictionary")
dict.comparemode = vbTextCompare
dict.Item("Sheet1") = Array("s.no", "cust.name", "product", "date")
dict.Item("Sheet2") = Array("prod.disc", "address", "pin")
dict.Item("Sheet50") = Array("foo", "bar")
With ThisWorkbook
For Each ky In dict.keys
With Worksheets(ky)
lc = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, _
MatchCase:=False, SearchFormat:=False).Column
For c = lc To 1 Step -1
'filter array method of 'not found in array'
'WARNING! CASE SENSITIVE SEARCH - foo <> FOO
If UBound(Filter(dict.Item(ky), .Cells(1, c).Value2)) = -1 Then
'.Cells(1, c).EntireColumn.Delete
Else
Debug.Print .Cells(1, c).Value2 & " at " & _
UBound(Filter(dict.Item(ky), .Cells(1, c).Value2))
End If
'worksheet MATCH method of 'not found in array'
'Case insensitive search - foo == FOO
If IsError(Application.Match(.Cells(1, c).Value2, dict.Item(ky), 0)) Then
.Cells(1, c).EntireColumn.Delete
Else
Debug.Print .Cells(1, c).Value2 & " at " & _
Application.Match(.Cells(1, c).Value2, dict.Item(ky), 0)
End If
Next c
End With
Next ky
End With
dict.RemoveAll: Set dict = Nothing
End Sub
Note that I have included two methods for determining whether a column header label is within the array of columns to keep. One is case-sensitive (the array Filter method) and the other is not (worksheet function MATCH method). The case-insensitive search method is currently active.
The code below selects tabs based on the color of the tab. Each sheet is formatted the same, they just contain different values. I am trying to using .find and offset to find a particular cell (it corresponds with current fiscal week plus one) and then copy and paste that cell as values instead of formulas. The code below selects the tabs needed and locates the correct cell but does not copy and paste that cell as values. I am trying to not name sheets specifically because this code will be used on multiple workbooks all with different tab names.
Sub freeze()
Dim ws As Worksheet
Dim strg() As String
Dim count As Integer
count = 1
For Each ws In Worksheets
If ws.Tab.Color = 255 Then
ReDim Preserve strg(count) As String
strg(count) = ws.Name
count = count + 1
Else
End If
Next ws
Sheets(strg(1)).Select
Dim aCell As Range
Set aCell = Range("B9:B79").Find(What:=Worksheets("EmailTemplate").Range("A1").Value)
If Not aCell Is Nothing Then
Sheets(strg(1)).aCell.Select
ActiveCell.Offset(0, 6).Select
Selection.copy
Selection.PasteSpecial xlPasteValues
Else
End If
For I = 2 To UBound(strg)
Sheets(strg(I)).Select False
Next I
End Sub
Thank you
Update #2 (Sun. 11:15 EDT) Added debug statements to assist you; Needed to add reference to 'ActiveSheet' in the 'Find' Code will loop thru all 'Red' sheets, find a match (if any) and copy/paste values.
Debug code will show Red tab names, search value, results, formula, value
Option Explicit
Sub freeze()
Dim ws As Worksheet
Dim aCell As Range
Dim strg() As String
Dim count As Integer
Dim i As Integer
count = 0
' Get each RED sheet
For Each ws In Worksheets
If ws.Tab.Color = 255 Then ' Find only RED tabs
Debug.Print "-----------------------------------------------------------------------"
Debug.Print "Name of Red Sheet: '" & ws.Name & "'" ' Debug...
'ReDim Preserve strg(count + 1) As String
'count = count + 1 ' This code not necessary as you can just reference the ws.name
'strg(count) = ws.Name ' Ditto
Sheets(ws.Name).Select
Set aCell = ActiveSheet.Range("B9:B79").Find(What:=Worksheets("EmailTemplate").Range("A1").value)
If Not aCell Is Nothing Then
ActiveSheet.Cells(aCell.Row, aCell.column).Select
ActiveCell.Offset(0, 6).Select ' Offset same row, + 6 columns
Debug.Print "Found Match for '" & Worksheets("EmailTemplate").Range("A1").value & _
"' in: R" & aCell.Row & ":C" & aCell.column & vbTab & "Formula: '" & ActiveCell.Formula & "'; Value: '" & ActiveCell.value & "'"
' Weird, but was unable to use 'aCell.Select' 2nd time thru loop
Selection.Copy
Selection.PasteSpecial xlPasteValues
Else
Debug.Print "Did NOT find a match for: '" & Worksheets("EmailTemplate").Range("A1").value & "' in sheet '" & ws.Name & "'"
End If
Application.CutCopyMode = False ' Unselect cell
End If
Next ws
End Sub
You can't do this:
Sheets(strg(1)).aCell.Select
The sheet is already stored in the range object aCell. You also shouldn't use select and pasting the value is not necessary. Here is what I would do:
Dim aCell As Range
Set aCell = Sheets(strg(1)).Range("B9:B79").Find(What:=Worksheets("EmailTemplate").Range("A1").Value)
If Not aCell Is Nothing Then
aCell.Offset(0, 6).Value = aCell.Offset(0, 6).Value
End If
I don't understand what you want to achieve with the second loop. .Select doesn't accept arguments I think?
edit: actually .Select does accept the replace option if applied to worksheets to extend the current selection, sorry about that!
I am having trouble with an asp page that contains a random function to display a random number of random records. The way I have the code now, as shown below, nothing appears on the page even though there are several records that match the criteria.
Out of 500 records I have in my database, about 70 match the criteria, but form some reason, they never seem to fall within the plist variable, to be used in the query.
When I change the max number to a lower number, say 10, I get an error message that the EOF has been found or no more records are available. Using debugging code, I couldnt find anything out of the ordinary, just the fact that from all the 100 records input into the plist, none of them match the records from the main criteria.
I am posting the entire code here. Maybe someone can catch what may be causing to not work properly.
Sub GetRandomDomains
dim conn, maxrecords, count, webname
dim randomrs, sql
'If (conn.State = adStateClosed) Then
OpenDB conn
'End If
count=0
maxrecords=100
KeywordColumnGetRandomKeywords conn, maxrecords, sql
If sql="" then
conn.close
set conn=nothing
Response.Write(" NOT AVAILABLE")
exit sub
end if
set randomrs=conn.execute(sql)
Response.Write("<ul id='catnav'>")
do While Not randomrs.EOF and count<maxrecords
If isnull(randomrs("sitename")) Then
webname=randomrs("domain")
Else
webname=randomrs("sitename")
End if
Response.Write "<li> " & webname &"</li>"
count=count+1
randomrs.movenext
loop
Response.Write("</ul>")
CloseSet randomrs
CloseDB conn
end sub
Sub KeywordColumnGetRandomKeywords (conn,maxrecords,sql)
dim i, id, index, plist, rs, sqlstr, sortstr
plist=""
Set rs=Server.CreateObject("ADODB.Recordset")
sqlstr="SELECT domainid FROM domains"
sqlstr=sqlstr
Debugwrite sqlstr, "sqlstr for random domains"
rs.Open sqlstr,conn,3,3
If rs.eof then
CloseSet rs
Response.Write(" EMPTY")
sql=""
exit sub
end if
Debugwrite rs("domainid"), "rs for random domains"
Dim arrData ' Array to Store Data
Dim arrSequence ' Array to Hold Random Sequence
Dim iArrayLooper ' Integer for Looping
Dim iarraysize ' Size of Data Array
If xdbasetype="Local" Then
iarraysize=cint(rs.recordcount)
else
iarraysize=cint(GetRecordcount (conn))
end if
Debugwrite GetRecordcount(conn), "getrecordcount for random domains array"
Debugwrite(IsArray(iarraysize)), "random domains count array"
'if (cint(GetRecordcount(conn)))= 0 or isnull(cint(GetRecordcount(conn))) then
'Exit Sub
'End if
redim arrdata(cint(iarraysize))
for i = 0 to iarraysize-1
arrData(i)=rs(0)
rs.movenext
next
rs.close
Set rs = Nothing
If iarraysize<maxrecords then
maxrecords=iarraysize
end if
' Get an array of numbers 0 to array size randomly sequenced.
arrSequence = Resequencearray(iArraySize)
for i = 0 to maxrecords-1
index=arrsequence(i)
id=arrdata(index)
if plist<>"" then
plist=plist & ","
end if
plist=plist & id
Next
sql="select domainid, domain, sitename,sitematch,altmatch from domains"
sql = sql & " WHERE restricted=0 and(sitematch like '%" & xsitematch & "%' or altmatch like '%" & xaltmatch & "%')"
sql = sql & " and domainid In (" & plist & ") "
Debugwrite sql, "first sql for random domains"
end sub
Function ResequenceArray(iArraySize)
Dim arrTemp()
Dim I
Dim iLowerBound, iUpperBound
Dim iRndNumber
Dim iTemp
' Set array size
ReDim arrTemp(iArraySize - 1)
Randomize
iLowerBound = LBound(arrTemp)
iUpperBound = UBound(arrTemp)
For I = iLowerBound To iUpperBound
arrTemp(I) = I
Next
' Loop through the array once, swapping each value
' with another in a random location within the array.
For I = iLowerBound to iUpperBound
iRndNumber = Int(Rnd * (iUpperBound - iLowerBound + 1))
' Swap Ith element with iRndNumberth element
iTemp = arrTemp(I)
arrTemp(I) = arrTemp(iRndNumber)
arrTemp(iRndNumber) = iTemp
Next 'I
' Return our array
ResequenceArray = arrTemp
End Function
'***********************************************************************
' get record count for mysql
'************************************************************************
Function GetrecordCount(conn)
dim sqlstr, rs, rcount
sqlstr="select count(domainid) FROM domains WHERE restricted=0 and (domaingroup='" & xdomaingroup & "' or altmatch like '%" & xaltmatch & "%')"
Debugwrite sqlstr, "sqlstr for random domains"
set rs=conn.execute(sqlstr)
if rs.eof then
rcount=0
else
rcount=rs(0)
end if
CloseSet rs
Getrecordcount=cint(rcount)
Debugwrite rcount, "getrecordcount for random domains"
End function
Okay. There may be a far more simple way of approaching this. Here's a piece of code that gets the data as an array - far simpler and we have much more control over what's in it...
'Constants relating to the following routines...
const C_NO_DATA = "NO_DATA" 'Used when no data is returned to a consuming routine
const C_ERROR = "ERROR" 'Used when an error is generated
'GetDataSet
' Returns a table of data based on the supplied SQL statement and connection string.
'Parameters:
' sqlString (string) - The SQL string to be sent.
' connString (string) - The database connection string.
'Usage:
' dataSet = GetDataSet(sqlString, connString)
'Description:
' This function generates a table of information in a 2 dimensional array. The first dimension represents the columns
' and the second the rows. If an error occurs while the routine is executing the array and the base index (0,0) is set
' to C_ERROR, (0,1) to the VBScript error index, and (0,2) to the VBScript error description.
function GetDataSet(sqlString, connString)
'Initialise...
dim returnVal, rsData
on error resume next
'Define and open the recordset object...
set rsData = Server.CreateObject("ADODB.RecordSet")
rsData.Open sqlString, connString, 0, 1, 1
'Initialise an empty value for the containing array...
redim returnVal(0,0)
returnVal(0,0) = C_NO_DATA
'Deal with any errors...
if not rsData.EOF and not rsData.BOF then
'Store the data...
returnVal = rsData.GetRows()
'Tidy up...
rsData.close
set rsData = nothing
select case err.number
case 3021 'No data returned
'Do nothing as the initial value will still exist (C_NO_DATA)
case 0 'No error
'Do nothing as data has been returned
case else
redim returnVal(4,0)
returnVal(0,0) = C_ERROR
returnVal(1,0) = err.number
returnVal(2,0) = err.description
returnVal(3,0) = sqlString
returnVal(4,0) = connString
end select
end if
on error goto 0
'Return the array...
GetDataSet = returnVal
end function
Okay, so we read the data we're after into an array. Note that I don't know where your xaltmatch and xsitematch variables come from so you'll need to supply these at some point...
Dim ds, sql
sql = _
"SELECT " & _
"domainid, " & _
"domain, " & _
"sitename, " & _
"sitematch, " & _
"altmatch " & _
"FROM " & _
"domains " & _
"WHERE " & _
"restricted=0 AND " & _
"(sitematch LIKE '%" & xsitematch & "%' OR " & _
"altmatch LIKE'%" & xaltmatch & "%') AND " & _
"domainid IN (" & plist & ") "
ds = GetDataSet(sql, conn)
The ds variable now contains an array of elements pulled from the database. All we need to do now is loop through the required number of times...
dim row, rows, used, randoms, col, cols, rc, cc
rows = UBound(ds, 2) 'Get the upper bound of the second array dimension
cols = UBound(ds, 1) 'Get the number of columns for writing to the page
randoms = 70 'Total number of randoms we need
used = ","
for rc = 1 to randoms
'Just in case we don't want to repeat the same row...
do
row = int(rnd(1)*rows) 'Zero based - we don't need to add 1
until instr(used, "," & row & ",")) = 0
'Add our random row to the list...
used = used & row & ","
'Write our output to the page...
response.write("<table>")
for cc = 0 to cols
response.write("<tr>")
response.write("<td>")
response.write(ds(cc, row))
response.write("</td>")
response.write("</tr>")
next 'cc
response.write("</table>")
next 'rc
The GetDataSet code is part of my stock functions, so I know that works, but I will hold my hand up and say that I haven't tested the rest of it.
Have a bash with this one, Luis, and let me know how you get on.