I have a very odd problem with one of my ASP scripts. It is a simple script, reads information from a database into a recordset and loops through the recordset, each time outputting HTML as a table row.
I'm having an issue where periodically it gets close to the end of its for each loop and it just stops without getting through all the recordsets. I know it is stopping because my resulting HTML only goes as far down as S or T in the recordset. The script is not crashing because underneath the for each loop I end the table and all that HTML is still present.
The odd thing is it is broken one refresh, then the next time I refresh it works - the data in the SQL Database is static and the ASP script is not changing. One load it can work, the next it can break.
I have no idea what is going on here so any advice is welcome!
One thing I tend to do is write the SQL to the page so I can see what's going on. Also, it might be helpful to write the count of the recordset to the page for debugging.
Try using something like this:
const C_NO_DATA = "NO_DATA"
const C_ERROR = "ERROR"
const C_COL_IDENTIFIER = 0
const C_COL_ERROR_ID = 1
const C_COL_ERROR_MESSAGE = 2
const C_COL_SQL = 3
const C_COL_CONNECTION = 4
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(C_COL_IDENTIFIER,0) = C_ERROR
returnVal(C_COL_ERROR_ID,0) = err.number
returnVal(C_COL_ERROR_MESSAGE,0) = err.description
returnVal(C_COL_SQL,0) = sqlString
returnVal(C_COL_CONNECTION,0) = connString
end select
end if
on error goto 0
'Return the array...
GetDataSet = returnVal
end function
This routine will read the data directly into an array so you can examine it at leisure.
-- EDIT --
Just to add to this, the reason I've provided the code like this is as a function to extract all of the data in one go rather than loop through an open database connection.
Related
I have ~150 Queries in a Microsoft Excel file. Clicking "Refresh all" would freeze my PC and resulted in some of the data not being able to load correctly even though network connection is good.
I'm looking to find a way to program "Refresh All" button so that it load maybe 5 to 10 queries at a time then move on the the next. I tried that manually and it loads without any problem. Just 150 queries at a time is too much.
Tks.
I couldn't find any simple way of resolving your query, but I have some thougts of a kind of a workaround. Below you can find two VBA macros that may help you a bit. The first code lists all queries that you have in your workbook in a new tab:
Sub ListQueries()
'Add tab to list all queries
Dim wsQueries As Worksheet
Set wsQueries = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
wsQueries.Name = "Query list"
wsQueries.Range("a1").Value = "Query name"
Dim con As WorkbookConnection
For Each con In ThisWorkbook.Connections
If UCase(Left(con.Name, 8)) = "QUERY - " Then wsQueries.Range("a1048576").End(xlUp).Offset(1, 0).Value = con.Name
Next con
End Sub
When it is finished you can use the second one. This time it will loop through all queries and refresh them but only as many as you will define in this clause If counter = 10 Then Exit For - if you want 15 then feel free to amend it. For each refereshed query it will add 'Yes' in column B. When you run RefreshQueries it at first checks whether a query is marked as 'Yes' and omit it if it's true.
Sub RefreshQueries()
Dim counter As Byte
counter = 0
'Range with query names
Dim rQueries As Range
Dim rQuery As Range
Dim wsQueries As Worksheet
Set wsQueries = ThisWorkbook.Worksheets("Query list")
Set rQueries = wsQueries.Range("a2:a" & wsQueries.Range("a1048576").End(xlUp).Row)
wsQueries.Range("b1") = "Refreshed"
For Each rQuery In rQueries
If counter = 10 Then Exit For 'if more than 10 queries refreshed then exit loop
'If query is refreshed then omit it and go to next
If rQuery.Offset(0, 1) <> "Yes" Then
ThisWorkbook.Connections(rQuery.Value).Refresh
rQuery.Offset(0, 1) = "Yes"
counter = counter + 1
End If
Next rQuery
End Sub
To sum up, you should run ListQueries once and RefreshQueries as many times as required to refresh all of them.
I am trying to retrieve records from Oracle SQL database and write them into a dictionary. Catch is that this code works as expected on my machine but no on my coworker's. On his end Recordset retrieves only one record even if that Recordset has RecordCount higher than one, meanwhile that same query pull up multiple records for me.
Initially I thought that MoveNext method is causing problems but once I switched to GetRows method issue persists. Anyway since this code works on my machine I'm fairly certain that my code correct, but you never know so I am including function in question here. The commented part contains the loop when I was using MoveNext but like I said changing that loop does not help with my problem.
Public Function WriteQueryToDict(SQL As String) As Dictionary
'First column of the query must contain key that will be used to locate records in the dictionary
'Output is a dictionary with first column as key, and the rest in an array that is indexed from 0
Dim Results As Recordset
Dim ResultsArray() As Variant
Dim cursorField As Integer
Dim cursorRow As Integer
Dim Output As Dictionary
Dim key As Variant
Dim record() As Variant
Set Results = RunQuery(SQL)
Set Output = New Dictionary
If Not (Results.BOF And Results.EOF) Then
' New loop
ResultsArray = Results.GetRows()
ReDim record(0 To (UBound(ResultsArray, 1) - 1))
For cursorRow = 0 To UBound(ResultsArray, 2)
key = ResultsArray(0, cursorRow)
For cursorField = 1 To UBound(ResultsArray, 1)
record(cursorField - 1) = ResultsArray(cursorField, cursorRow)
Next
Output.Add key, record
Next
' Original loop
'Results.MoveFirst
'Do
' For cursorField = 1 To Results.fields.Count - 1
' record(cursorField) = Results.fields(cursorField).Value
' Next
'
' key = Results.fields(0)
' Output.Add key, record
' Results.MoveNext
'Loop Until Results.EOF
End If
Set WriteQueryToDict = Output
End Function
In case this might be relevant this is function that does the actual connection + querying:
Private Function RunQuery(SQL As String) As Recordset
Dim Username As String
Dim Password As String
Dim DBConn As ADODB.Connection
Username = ThisWorkbook.Sheets("Configuration").Range("C3").Value
Password = ThisWorkbook.Sheets("Configuration").Range("C4").Value
Set DBConn = New ADODB.Connection
With DBConn
.Provider = "OraOLEDB.Oracle.1;user id = " & Username & "; password = " & Password
.CONNECTIONSTRING = "Data Source=" & DB
.Open
End With
Set RunQuery = DBConn.Execute(SQL)
End Function
I am guessing that this has to do with some setting set outside of my code, my colleague has no knowledge to configure oracle drivers on his own so I am at loss as to what tis might be. Anyway I've never seen my code produce such differences between two different machines so I'm not sure what am I looking for to fix this problem, I will share additional details as needed if you can tell what might be missing here.
Thank you
UPDATE:
When debugigng I setup a breakpoint inside WriteQueryToDict right before the loop starts, that way I was able to Play with Recordset itself first check the RecordCount property to make sure that we have records to iterate over last time I ran this on his machine I saw about 60 records, then call MoveFirst and my epectation is that now I will be able to call MoveNext 60 times before EOF turns true, instead it turn true after first call. while at it I tried setting cursorLocation to Client but that didn't have any effect.
I keep having an issue with some code in VBA Excel was looking for some help!
I am trying to sort through a list of names with corresponding phone numbers, checking for multiple names under the same phone number. Then post those names to a separate sheet.
So far my code is:
Sub main()
Dim cName As New Collection
For Each celli In Columns(3).Cells
Sheets(2).Activate
On Error GoTo raa
If Not celli.Value = Empty Then
cName.Add Item:=celli.Row, Key:="" & celli.Value
End If
Next celli
On Error Resume Next
raa:
Sheets(3).Activate
Range("a1").Offset(celli.Row - 1, 0).Value = Range("a1").Offset(cName(celli.Value) - 1, 0).Value
Resume Next
End Sub
When I try to run the code it crashes Excel, and does not give any error codes.
Some things I've tried to fix the issue:
Shorted List of Items
Converted phone numbers to string using cstr()
Adjusted Range and offsets
I'm pretty new to all this, I only managed to get this far on the code with help from other posts on this site. Not sure where to go with this since it just crashes and gives me no error to look into. Any ideas are appreciated Thank you!
Updated:
Option Explicit
Dim output As Worksheet
Dim data As Worksheet
Dim hold As Object
Dim celli
Dim nextRow
Sub main()
Set output = Worksheets("phoneFlags")
Set data = Worksheets("filteredData")
Set hold = CreateObject("Scripting.Dictionary")
For Each celli In data.Columns(3).Cells
On Error GoTo raa
If Not IsEmpty(celli.Value) Then
hold.Add Item:=celli.Row, Key:="" & celli.Value
End If
Next celli
On Error Resume Next
raa:
nextRow = output.Range("A" & Rows.Count).End(xlUp).Row + 1
output.Range("A" & nextRow).Value = data.Range("A1").Offset(hold(celli.Value) - 1, 0).Value
'data.Range("B1").Offset(celli.Row - 1, 0).Value = Range("B1").Offset(hold
Resume Next
End Sub
Update2:
Used hold.Exists along with an ElseIf to remove the GoTo's. Also changed it to copy and paste the row to the next sheet.
Sub main()
Set output = Worksheets("phoneFlags")
Set data = Worksheets("filteredData")
Set hold = CreateObject("Scripting.Dictionary")
For Each celli In data.Columns(2).Cells
If Not hold.Exists(CStr(celli.Value)) Then
If Not IsEmpty(celli.Value) Then
hold.Add Item:=celli.Row, Key:="" & celli.Value
Else
End If
ElseIf hold.Exists(CStr(celli.Value)) Then
data.Rows(celli.Row).Copy (Sheets("phoneFlags").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0))
'output.Range("A" & nextRow).Value = data.Range("A1").Offset(hold(celli.Value) - 1, 0).Value
End If
Next celli
End Sub
When developing code, don't try (or be afraid of) errors as they are pointers to help fix the code or the logic. As such, don't use On Error unless it is absolutely indicated in the coding algorithm (*). using On Error when not necessary only hides errors, does not fix them and when coding it is always better to avoid the errors in the first place (good logic).
When adding to the Dictionary, first check to see if the item already exists. The Microsoft documentation notes that trying to add an element that already exists causes an error. An advantage that the Dictionary object has over an ordinary Collection object in VBA is the .exists(value) method, which returns a Boolean.
The short answer to your question, now that I have the context out of the way, is that you can first check (if Not hold.exists(CStr(celli.Value)) Then) and then add if it does not already exist.
(*) As a side note, I was solving an Excel macro issue yesterday which took me most of the day to nut out, but the raising of errors and the use of debugging code helped me make some stable code rather than some buggy but kind-of-working code (which is what I was fixing in the first place). However, the use of error handling can be a short cut in some instances such as:
Function RangeExists(WS as Worksheet, NamedRange as String) As Boolean
Dim tResult as Boolean
Dim tRange as Range
tResult = False ' The default for declaring a Boolean is False, but I like to be explicit
On Error Goto SetResult ' the use of error means not using a loop through all the named ranges in the WS and can be quicker.
Set tRange = WS.Range(NamedRange) ' will error out if the named range does not exist
tResult = True
On Error Goto 0 ' Always good to explicitly limit where error hiding occurs, but not necessary in this example
SetResult:
RangeExists = tResult
End Function
I have an Excel application I've developed and now want to store all of the data in an Access file (rather than an Excel sheet). I'm able to read data in and write data out, my issue has to do with handling concurrent users. There's around 150-200 square images that when clicked open up a UserForm that is loaded with data. Users are able to go in and edit any of that data so I want to make sure that two users are not editing a record at the same time. Given the size of it I do not want to lock down the entire file, just the one record. Everything I've read so far indicates that the record only locks while in .Edit, however I want to lock it as soon as the user opens the UserForm, then apply any edits they made and unlock it.
Here's where I'm at now with the code, the first three sections are where the main focus is with this:
Sub OpenDAO()
Set Db = DBEngine.Workspaces(0).OpenDatabase(Path, ReadOnly:=False)
strSQL = "SELECT * FROM AccessDB1 WHERE ID = 5" '& Cells(1, Rng.Column)
Set Rs = Db.OpenRecordset(strSQL)
End Sub
'==========================================================================
Sub CloseDAO()
On Error Resume Next
Rs.Close
Set dbC = Nothing
Set Rs = Nothing
Set Db = Nothing
End Sub
'==========================================================================
Function ADO_update(Target As Range)
Set ws = Sheets("Sheet1")
Set dbC = DBEngine.Workspaces(0).Databases(0)
'if no change exit function
If Target.Value = oldValue Then GoTo 0
On Error GoTo trans_Err
'begin the transaction
DBEngine.BeginTrans
dbC.Execute "UPDATE AccessDB1 SET Field1 = 5 WHERE ID= 5"
DBEngine.CommitTrans dbForceOSFlush
Exit Function
trans_Err:
'roll back the transaction
Workspaces(0).Rollback
0
End Function
'==========================================================================
Function MakeSQLText(data As Variant)
If (IsNumeric(data)) Then
MakeSQLText = data
Else
MakeSQLText = "'" & Replace(data, "'", "''") & "'"
End If
End Function
Running a Excel VBA loop to perform following:
(1) Open Access Database
(2) Run macros in Access database to import data
(3) Close Access database completely
Excel VBA loop works fine on first iteration but on 2nd iteration stops at first Access macro. If disable the following 2 Excel VBA steps, loop runs as desired (except database not closed at end of each loop):
(1) oAccess.DoCmd.Close
(2) oAccess.DoCmd.Quit
Any idea how to completely close database (no shell open) at end of each loop iteration and get macros to run on following iterations? Thanks.
Dim DataBaseLoc As String
Dim oAccess As Access.Application
For K = First To Last
Set oAccess = New Access.Application
oAccess.Visible = True
If Z = "" Then DataBaseLoc = "C:\AutoInsight.mdb"
If Z <> "" Then DataBaseLoc = "C:\AutoInsight_X.mdb"
oAccess.OpenCurrentDatabase DataBaseLoc
If Z = "" Then Set ObjAccess = GetObject("AutoInsight.mdb")
If Z <> "" Then Set ObjAccess = GetObject("AutoInsight_X.mdb")
With ObjAccess
DoCmd.RunMacro "mcr_Import_Parts"
End With
With ObjAccess
For i = 1 To 2
If i = 1 Then DoCmd.RunMacro "mcr_Import_C"
If i = 2 Then DoCmd.RunMacro "mcr_Import_I"
Next i
End With
oAccess.DoCmd.Close
oAccess.DoCmd.Quit
Next K
Try this instead:
End With
Set ObjAccess = Nothing
oAccess.DoCmd.Close
oAccess.DoCmd.Quit
Set oAccess = Nothing
Next K
VBA should eventually notice that the objects which ObjAcess and oAccess referred to are no longer valid and dispose of them but it can be helpful to make things explicit by setting the variables to "Nothing". This is especially the case when the variables don't go out of scope (which is the case here)