ADO recordset seems to cache old results - excel

I am having an issue where I create a connection string (Excel) and query a worksheet, I can get the results, placed into a recordset, and then transposted into a destination worksheet.
The problem is that for some reason, if I go back and edit this worksheet (without saving), the recordset is caching the OLD results. eg: I first queried 10 rows, returned 10, deleted 7 of them, execute the query again but it returns the original 10 as opposed to my expectation for the remaining 3. I've used this method thoroughly and have never had this issue and believe it to be memory related somehow...
Please help...
Public Sub sbTest()
Dim wb As Workbook
Dim wsData As Worksheet, _
wsTmp As Worksheet
Set wb = ThisWorkbook
Set wsData = wb.Sheets("Data"): wsData.Cells.ClearContents
Set wsTmp = wb.Sheets("Temporary")
sSQL = "SELECT * FROM [" & wsTmp.Name & "$]"
Call mUtilities.sbRunSQL(sConnXlsm, wb.FullName, sSQL, wsData.Cells(1, 1))
'Cleanup
Set wb = Nothing
Set wsData = Nothing
Set wsTmp = Nothing
End Sub
Public Const sConnXlsm As String = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=zzzzz;Extended Properties=""Excel 12.0 Macro;HDR=YES;IMEX=1"";"
Public Sub sbRunSQL(ByVal sConn As String, ByVal sSource As String, ByVal sSQL As String, ByVal rDest As Range, _
Optional ByVal bHeader As Boolean = True, Optional ByVal bMsg As Boolean = True)
Dim oCn As ADODB.Connection, _
oRs As ADODB.Recordset, _
oFld As ADODB.Field
Dim vArr As Variant
'Setup
On Error GoTo Cleanup
'Handle DELETE and INSERT INTO Access queries seperately from other types
If (UCase(Left(sSQL, 6)) = "DELETE" Or UCase(Left(sSQL, 11)) = "INSERT INTO") And sConn = sConnAccess Then
Set oCn = CreateObject("ADODB.Connection")
oCn.Open Replace(sConn, "zzzzz", sSource)
sSQL = Replace(sSQL, "FROM ", "FROM [Excel 8.0;HDR=YES;DATABASE=" & ThisWorkbook.FullName & "].")
oCn.Execute sSQL
'Exit if successful
oCn.Close
Set oCn = Nothing
Exit Sub
Else
Set oRs = Nothing
Set oRs = New ADODB.Recordset
oRs.Open sSQL, Replace(sConn, "zzzzz", sSource), adOpenForwardOnly, adLockReadOnly
If Not (oRs.BOF And oRs.EOF) Then
vArr = oRs.GetRows
vArr = fTranspose(vArr) 'The .GetRows process tranposes the data so we need to undo this
If bHeader = True Then
For i = 0 To oRs.Fields.Count - 1
rDest.Offset(0, i).Value = oRs.Fields(i).Name
Next i
Range(rDest.Offset(1, 0), rDest.Offset(UBound(vArr, 1) + 1, UBound(vArr, 2))) = vArr
Else
Range(rDest, rDest.Offset(UBound(vArr, 1), UBound(vArr, 2))) = vArr
End If
'Exit if successful
oRs.Close
Set oRs = Nothing
Exit Sub
End If
End If
'Cleanup
Cleanup:
If bMsg = True Then
MsgBox "Critical error!" & vbNewLine & vbNewLine & _
"Error: " & Err.Description & vbNewLine & vbNewLine & _
"SQL: " & sSQL, vbCritical + vbOKOnly
End If
Set oCn = Nothing
Set oRs = Nothing
End Sub

For what it's worth, I was able to solve this and the issue seems to be related to some kind of latency bug if multiple instances of Excel are open. I've simply forced only one book to be open in such cases.
Set oWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set oProc = oWMI.ExecQuery("SELECT * FROM Win32_Process WHERE NAME = 'Excel.exe'")
If oProc.Count > 1 Then
MsgBox "There are " & oProc.Count & " instances of Excel open." & vbNewLine & vbNewLine & _
"Only 1 instance is allowed open in order to update database.", vbCritical + vbOKOnly
GoTo Cleanup
End If

Related

Copy data from closed workbook to another open workbook in VBA?

I know this has probably been asked before but I was wondering if it was possible to copy data from another 'closed' workbook to my current open workbook. If tried to look up some things and everywhere says it is not possible... I know it's a bit of an open ended question.
Ah, this takes me back a few years. I believe this was done by Ron years ago (explained on a different platform). But there are two ways to do it. One method I forgot and gets the cells one by one and the other is the ADO method posted below. First there are two example subs (one method to bring headers and the other to not) and then followed by the main ADO sub.
Option Explicit
Sub GetData_ExampleV1()
' It will copy the Header row also (the last two arguments are True)
' Change the last argument to False if you not want to copy the header row
GetData ThisWorkbook.Path & "\test.xlsx", "Sheet1", _
"A1:C5", Sheets("Sheet1").Range("A1"), True, True
End Sub
Sub GetData_ExampleC2()
' It will not copy the Header row (the last two arguments are True, False)
' Change the last argument to True if you also want to copy the header row
GetData ThisWorkbook.Path & "\test.xlsx", "Sheet1", _
"A1:C5", Sheets("Sheet1").Range("A1"), True, False
End Sub
This is the ADO (function) you call to do it.
Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
Dim rsCon As Object
Dim rsData As Object
Dim szConnect As String
Dim szSQL As String
Dim lCount As Long
' Create the connection string.
If Header = False Then
If Val(Application.Version) < 12 Then
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=No"";"
Else
szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 12.0;HDR=No"";"
End If
Else
If Val(Application.Version) < 12 Then
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=Yes"";"
Else
szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 12.0;HDR=Yes"";"
End If
End If
If SourceSheet = "" Then
' workbook level name
szSQL = "SELECT * FROM " & SourceRange$ & ";"
Else
' worksheet level name or range
szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
End If
On Error GoTo SomethingWrong
Set rsCon = CreateObject("ADODB.Connection")
Set rsData = CreateObject("ADODB.Recordset")
rsCon.Open szConnect
rsData.Open szSQL, rsCon, 0, 1, 1
' Check to make sure we received data and copy the data
If Not rsData.EOF Then
If Header = False Then
TargetRange.Cells(1, 1).CopyFromRecordset rsData
Else
'Add the header cell in each column if the last argument is True
If UseHeaderRow Then
For lCount = 0 To rsData.Fields.Count - 1
TargetRange.Cells(1, 1 + lCount).Value = _
rsData.Fields(lCount).Name
Next lCount
TargetRange.Cells(2, 1).CopyFromRecordset rsData
Else
TargetRange.Cells(1, 1).CopyFromRecordset rsData
End If
End If
Else
MsgBox "No records returned from : " & SourceFile, vbCritical
End If
' Clean up our Recordset object.
rsData.Close
Set rsData = Nothing
rsCon.Close
Set rsCon = Nothing
Exit Sub
SomethingWrong:
MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _
vbExclamation, "Error"
On Error GoTo 0
End Sub

Load aggregate data from Excel into ADODB.RecordSet

I am trying to load data from an Excel file in a specific sheet into an ADODB.RecordSet via a VBA macro by using SQL SELECT command.
There are several columns on the Excel sheet, and I don't need all of them.
For example:
col.A = Surname, col.B = Name, col.C = IDPerson, [....columns that are not needed], Col.N = Boss
The purpose would be to get a recordset of aggregated data for:
col.C = IDPerson, col.N = Boss.
The fields highlighted in the image below.
I would like to have a RecordSet with the aggregated (non-repeating) data of the columns highlighted in yellow.
Obviously, this problem could also be solved by loading a matrix, but, in this case I would have to build a loading algorithm to "clean" any repetitions in the data and then later I would have to provide a search function with some loops.
So I thought that if I could load all the data I need by reading the WorkSheet as if it were a data table and then make a query on it to extract the data that I need and load everything in an ADODB.RecordSet would be much more efficient also for searching for data (filter data for example).
Below I report my code that loads all the data of my sheet:
Public Sub LoadRecordSet(ByVal LastRow As Long, ByVal LastCol As Integer)
Dim cnt As ADODB.Connection
Dim rsData As ADODB.Recordset
Dim strSQL As String
Dim strTMP As String
strTMP = Cells(LastRow, LastCol).Address
strTMP = Replace(strTMP, "$", "")
Set cnt = New ADODB.Connection
cnt.Mode = adModeRead
cnt.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & ActiveWorkbook.FullName & ";" & _
"Extended Properties=""Excel 12.0 Macro;HDR=Yes;"";"
cnt.Open
strSQL = "SELECT * FROM [Sheet1$C2:" & strTMP & "]"
Set rsData = New ADODB.Recordset
With rsData
Set .ActiveConnection = cnt
.Source = strSQL
.CursorLocation = adUseClient
.CursorType = adOpenKeyset
.LockType = adLockOptimistic
.Open
End With
'TODO - Something with rsData for filtering or to research
'GC
If Not rsData Is Nothing Then
If rsData.State <> adStateClosed Then rsData.Close
Set rsData = Nothing
End If
If Not cnt Is Nothing Then
If cnt.State <> adStateClosed Then cnt.Close
Set cnt = Nothing
End If
End Sub
My question is: "What if I just want to load some columns as described above and aggregate them so they don't have repetitions in the data?"
For example if I want to load similar
SELECT [cod.fiscale], responsabile FROM [MySheet$A3:N480] GROUP BY [cod.fiscale], responsabile
It's possible?
Thank you so much.
I improved my code which is now working:
Public Sub CaricaDati()
Dim cnt As ADODB.Connection
Dim rsDati As ADODB.Recordset
Dim strSQL As String
Dim strTMP As String
Dim i As Integer
on Error GoTo Error_Handler
Range("A3").Select
g_BOLTS_UltimaRiga = LasRow
Call LastCol
strTMP = Cells(g_LastRow, g_LastCol).Address
strTMP = Replace(strTMP, "$", "")
Set cnt = New ADODB.Connection
cnt.Mode = adModeRead
cnt.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & ActiveWorkbook.FullName & ";" & _
"Extended Properties=""Excel 12.0 Macro;HDR=Yes;"";"
cnt.Open
'strSQL = "SELECT * FROM [2$C2:" & strTMP & "]"
strSQL = "SELECT cf, responsabile FROM [2$C2:" & strTMP & "] GROUP BY cf, responsabile"
Set rsDati = New ADODB.Recordset
With rsDati
Set .ActiveConnection = cnt
.Source = strSQL
.CursorLocation = adUseClient
.CursorType = adOpenKeyset
.LockType = adLockOptimistic
.Open
End With
If Not (rsDati.BOF And rsDati.EOF) Then
strTMP = ""
For i = 0 To rsDati.Fields.Count - 1
strTMP = strTMP & rsDati.Fields(i).Name & ";"
Next i
Debug.Print strTMP
strTMP = ""
rsDati.MoveFirst
Do While Not rsDati.EOF
strTMP = ""
For i = 0 To rsDati.Fields.Count - 1
strTMP = strTMP & rsDati.Fields(i).Value & ";"
Next i
Debug.Print strTMP
rsDati.MoveNext
Loop
End If
Uscita:
On Error Resume Next
'GC
If Not rsDati Is Nothing Then
If rsDati.State <> adStateClosed Then rsDati.Close
Set rsDati = Nothing
End If
If Not cnt Is Nothing Then
If cnt.State <> adStateClosed Then cnt.Close
Set cnt = Nothing
End If
Exit Sub
Error_Handler:
On Error GoTo 0
MsgBox Err.Number & " - " & Err.Description, vbOKOnly + vbCritical, "ERRORE IMPREVISTO"
GoTo Uscita
End Sub

No data transfer to Access with ADODB recordset

I have created an excel linked access database with VBA that works when I use a centrally saved version but not when I save a local copy.
I have used the Debug tool and the code skips my For loop in the locally saved copy.
For x = 2 To nextrow
DatabaseData.AddNew
For i = 1 To 35
DatabaseData(Cells(1, i).Value) = Sheet18.Cells(x, i).Value
Next i
DatabaseData.Update
Next x
I think that this is because the Recordset (DatabaseData) is not being recognized (not sure if that is the correct term).
The code is below
Sub CopyDatatoAccess()
Dim DatabaseConn As ADODB.Connection
Dim DatabaseData As ADODB.Recordset
Dim Pathway
Dim x As Long, i As Long
Dim nextrow As Long
On Error GoTo errorhandler:
Pathway = Sheet18.Range("AQ2").Value
nextrow = Sheet18.Range("AR2")
Set DatabaseConn = New ADODB.Connection
If Sheet18.Range("A2").Value = "" Then
MsgBox "ARF form is not present for Upload"
Exit Sub
End If
DatabaseConn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Pathway
Set DatabaseData = New ADODB.Recordset
DatabaseData.Open Source:="ARFs", _
ActiveConnection:=DatabaseConn, _
CursorType:=adOpenDynamic, _
LockType:=adLockOptimistic, _
Options:=adCmdTable
For x = 2 To nextrow
DatabaseData.AddNew
For i = 1 To 35
DatabaseData(Cells(1, i).Value) = Sheet18.Cells(x, i).Value
Next i
DatabaseData.Update
Next x
DatabaseData.Close
DatabaseConn.Close
Set DatabaseData = Nothing
Set DatabaseConn = Nothing
MsgBox "The ARF is now uploaded"
Application.ScreenUpdating = True
Sheet18.Cells.Range("AK2").Value = Sheet18.Cells.Range("AK4").Value + 1
On Error GoTo 0
Exit Sub
errorhandler:
Set DatabaseData = Nothing
Set DatabaseConn = Nothing
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Export_Data"
End Sub

Importing Excel worksheet range to Ms Access Table

Good Afternoon,
I have created a Macro that uploads data to a access database ( both on my desktop). The problem is it I keep getting errors when I try to expand the range.
I presumed it would be something simple but seems to be something I am overlooking.
here is the code - basically I would like to include the column or set it to a dynamic range? can you please help?
Sub AccessCode()
Application.ScreenUpdating = False
Dim db As Database
Dim rs As DAO.Recordset
Set db = OpenDatabase("C:\Users\user\Desktop\Test Copy.accdb")
Set rs = db.OpenRecordset("Fact Table", dbOpenTable)
rs.AddNew
rs.Fields("GUID") = Range("g2").Value
rs.Fields("StageID") = Range("h2").Value
rs.Fields("Sync Date") = Range("i2").Value
rs.Fields("Forecast HP") = Range("j2").Value
rs.Fields("Owner Id") = Range("k2").Value
rs.Fields("Recent Modified Flag") = Range("L2").Value
rs.Fields("Upload Date") = Range("M2").Value
rs.Update
rs.Close
db.Close
Application.ScreenUpdating = True
MsgBox " Upload To PMO Database Successful."
End Sub
You can use a query instead of iterating through a recordset:
Sub AccessCode()
Application.ScreenUpdating = False
Dim db As Database
Dim rs As DAO.Recordset
Set db = OpenDatabase("C:\Users\user\Desktop\Test Copy.accdb")
db.Execute "INSERT INTO [Fact Table] ([GUID], [StageID], etc) " & _
"SELECT * FROM [SheetName$G:M] " & _
"IN """ & ActiveWorkbook.FullName & """'Excel 12.0 Macro;HDR=No;'"
End Sub
This has numerous advantages, such as often being faster because you don't have to iterate through all the fields.
If you would trigger the import from Access instead of Excel, you wouldn't even need VBA to execute the query.
Change the rs section to this one:
With rs
.addnew
!GUID = Range("g2").Value
!StageID = Range("h2").Value
'...etc
.Update
End With
MSDN source
Use the AddNew method to create and add a new record in the Recordset object named by recordset. This method sets the fields to default values, and if no default values are specified, it sets the fields to Null (the default values specified for a table-type Recordset).
After you modify the new record, use the Update method to save the changes and add the record to the Recordset. No changes occur in the database until you use the Update method.
Edit:
This is how your code should look like, when you change the rs section with the code above:
Sub AccessCode()
Application.ScreenUpdating = False
Dim db As Database
Dim rs As DAO.Recordset
Set db = OpenDatabase("C:\Users\user\Desktop\Test Copy.accdb")
Set rs = db.OpenRecordset("Fact Table", dbOpenTable)
With rs
.addnew
!GUID = Range("g2").Value
!StageID = Range("h2").Value
'...etc
.Update
.Close
End With
Application.ScreenUpdating = True
MsgBox " Upload To PMO Database Successful."
End Sub
Just thought I'd add in an alternative to #Erik von Asmuth's excellent answer. I use something like this in a real project. It's a little more robust for importing a dynamic range.
Public Sub ImportFromWorksheet(sht As Worksheet)
Dim strFile As String, strCon As String
strFile = sht.Parent.FullName
strCon = "Excel 12.0;HDR=Yes;Database=" & strFile
Dim strSql As String, sqlTransferFromExcel As String
Dim row As Long
row = sht.Range("A3").End(xlDown).row
Dim rng As Range
sqlTransferFromExcel = " Insert into YourTable( " & _
" [GUID] " & _
" ,StageID " & _
" ,[sync Date] " & _
" ,[etc...] " & _
" ) " & _
" SELECT [GUID] " & _
" ,StageID " & _
" ,[sync Date] " & _
" ,[etc...] " & _
" FROM [{{connString}}].[{{sheetName}}$G2:M{{lastRow}}]"
sqlTransferFromExcel = Replace(sqlTransferFromExcel, "{{lastRow}}", row)
sqlTransferFromExcel = Replace(sqlTransferFromExcel, "{{connString}}", strCon)
sqlTransferFromExcel = Replace(sqlTransferFromExcel, "{{sheetName}}", sht.Name)
CurrentDb.Execute sqlTransferFromExcel
End Sub

Iterate over defined lists in excel

I have an excel spreadsheet, with two defined lists. Call them colours{red, green, blue} and types{1, 2}
I have a function to calculate for each object, so finally, I have a table that looks like
colour type result
red 1 100
red 2 200
green 1 150
green 2 250
blue 1 155
blue 2 255
But obviously I wrote that by hand. Without using a VB script, is there any way I can get excel to fill in the colour and type cells to enumerate the whole set?
Thanks
Here's one VBA approach - you can pass in as many lists (by range) as you like and it will create all the combinations and copy them to where you specify.
Sub tester()
'First range is where to place the results, next ranges
' are the lists to be combined
SqlPermutate Sheet1.Range("E1"), Sheet1.Range("A1:A20"), _
Sheet1.Range("B1:B5"), Sheet1.Range("C1:C10")
End Sub
Sub SqlPermutate(rngDestination As Range, ParamArray ranges() As Variant)
Dim oConn As Object, oRS As Object
Dim sPath, i As Long, srcWb As Workbook
Dim sSQL As String, flds As String, tbls As String
'check source ranges are in a saved workbook...
Set srcWb = ranges(0).Parent.Parent
If srcWb.Path <> "" Then
sPath = srcWb.FullName
Else
MsgBox "Workbook being queried must be saved first..."
Exit Sub
End If
For i = LBound(ranges) To UBound(ranges)
flds = flds & IIf(Len(flds) > 0, ",", "") & Chr(65 + i) & ".*"
tbls = tbls & IIf(Len(tbls) > 0, ",", "") & _
RngNm(ranges(i)) & " " & Chr(65 + i)
Next i
sSQL = "select " & flds & " from " & tbls
Debug.Print sSQL
Set oConn = CreateObject("adodb.connection")
Set oRS = CreateObject("ADODB.Recordset")
oConn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & sPath & "';" & _
"Extended Properties='Excel 12.0;HDR=no;IMEX=1';"
oRS.Open sSQL, oConn
If Not oRS.EOF Then
rngDestination.CopyFromRecordset oRS
Else
MsgBox "No records found"
End If
oRS.Close
oConn.Close
End Sub
Function RngNm(r) As String
RngNm = "[" & r.Parent.Name & "$" & _
r.Address(False, False) & "]"
End Function

Resources