I wrote the proc below, and it's working fine, except that I would like to check if the recordset is empty or not. However, rs.EoF and rs.BoF always return False, even if there is no data. What is the trick to make this work ?
Sub PrepData()
Dim ws As Worksheet, wb As Workbook
Dim cn As New ADODB.Connection
Dim rs As ADODB.Recordset
Dim rs2 As ADODB.Recordset
Dim strSql As String, recs As Long
Set wb = ActiveWorkbook
Set ws = ActiveSheet
'create connection
With cn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.ConnectionString = "Data Source=" & wb.FullName & ";" & _
"Extended Properties=""Excel 12.0;HDR=YES"";"
.Open
End With
'check trades without matching couterparty
strSql = "select distinct tf.counterPart from [TradeFile$A3:G5000] tf " & _
"left join [CounterpartiesMapping$] c on tf.counterpart = c.counterpart " & _
"where c.investee is null"
Set rs = cn.Execute(strSql, recs)
'HERE I'd like to see if the recordset is empty,
'but rs.eof and rs.bof are always FALSE regardless of the result
Debug.Print rs.BOF, rs.EOF, rs.RecordCount
ws.Range("p3").CopyFromRecordset rs
rs.Close
cn.Close
End Sub
Have you tried using the RecordCount property for the recordset to find the number of rows returned?
Debug.Print rs.RecordCount
I finally found the solution here:
Just replace
Set rs = cn.Execute(strSql, recs)
By
Set rs = New ADODB.Connection
rs.CursorLocation = adUseCLient
rs.Open strSql, cn
Now Debug.Print rs.BOF, rs.EOF, rs.RecordCount works as expected!
Related
I am trying to insert some values on the last row of the recordset which in this case is an Excel file that serves as my database. I have the code below that works in inserting the value of the textbox to the last row of the excel recordset. However, it did not create a new table row where the value was inserted.
Sub CreaterRow()
Dim strFile As String
Dim strConnect As String
Dim strSQL As String
Dim lngCount As Long
Dim cnn As New ADODB.Connection
Dim rst As New ADODB.Recordset
strFile = "C:\Excel\Test.xlsx"
strConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFile & _
";Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
cnn.Open ConnectionString:=strConnect
strSQL = "SELECT [ID] FROM [Sheet1$]"
rst.Open Source:=strSQL, ActiveConnection:=cnn, CursorType:=adOpenForwardOnly, Options:=adCmdText
With rst
.AddNew
.Fields("ID").Value = tbx_ID.Value 'Inserting this in the recordset did not create a new row
.Update
End with
rst.Close
cnn.Close
End Sub
How can the table automatically create a new row that will include the value is inserted in the lastrow? Thank you.
This worked for me. You need to have the right cursor and lock type.
Sub CreaterRow()
Dim strFile As String
Dim strConnect As String
Dim strSQL As String
Dim cnn As New ADODB.Connection
Dim rst As New ADODB.Recordset
strFile = ThisWorkbook.Path & "\Data.xlsx"
strConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=""" & strFile & _
""";Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
cnn.Open ConnectionString:=strConnect
strSQL = "SELECT [ID] FROM [Sheet1$]"
rst.Open strSQL, cnn, adOpenKeyset, adLockOptimistic
With rst
.AddNew
.Fields("ID").Value = "ID00020"
.Update
End With
rst.Close
cnn.Close
End Sub
EDIT: if you're querying data from a Table/Listobject then appending records will not resize the list to include the added records. See: ADO: Excel: Is it possible to open recordset on table name?
EDIT2: If you use a named range instead of a ListObject, then you can query it by name (instead of using the sheet name) and the range will adjust when you insert new rows.
I tried the code in this link to push and retrieved the data between Excel and Access. I modified the code based on my file path as following:
EDITED NEW CODE BLOCK
Sub UpdateMDB()
Dim accConn As Object, accRST As Object
Dim accFile As String, accStr As String
Dim lastrow As Long, i As Long
lastrow = Workbooks(1).Sheets(1).Cells(Workbooks(1).Sheets(1).Rows.Count, "A").End(xlUp).Row
accFile = "Z:\Documents\Database\Database1.mdb"
accStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & accFile & ";"
Set accConn = CreateObject("ADODB.Connection")
Set accRST = CreateObject("ADODB.Recordset")
accConn.Open accStr
accRST.Open "SELECT * FROM Table1", accConn, adOpenKeyset, adLockOptimistic, adCmdTableDirect
If Not (accRST.BOF And accRST.EOF) Then
accRST.MoveFirst
Else
MsgBox "No records in Access table.", vbInformation
accRST.Close: accConn.Close: Set accRST = Nothing: Set accConn = Nothing
Exit Sub
End If
Do While Not accRST.EOF
For i = 1 To lastrow
If accRST!ID = Workbooks(1).Sheets(1).Range("A" & i) _
And accRST!Field1 <> Workbooks(1).Sheets(1).Range("B" & i) Then
accRST!Field1.Value = Workbooks(1).Sheets(1).Range("B" & i)
End If
Next i
accRST.Update
accRST.MoveNext
Loop
accRST.Close: accConn.Close
Set accRST = Nothing: Set accConn = Nothing
End Sub
INITIAL CODE BLOCK
Sub GetMDB()
Dim cn As Object
Dim rs As Object
strFile = "Z:\Documents\Database\Database1.mdb"
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile & ";"
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Open strCon
strSQL = "SELECT * FROM Table1"
rs.Open strSQL, cn
With Worksheets(1)
For i = 0 To rs.Fields.Count - 1
.Cells(1, i + 1) = rs.Fields(i).Name
Next
rs.MoveFirst
.Cells(2, 1).CopyFromRecordset rs
End With
End Sub
Sub UpdateMDB()
Dim cn As Object
Dim rs As Object
''It would probably be better to use the proper name, but this is
''convenient for notes
strFile = Workbooks(1).FullName
''Note HDR=Yes, so you can use the names in the first row of the set
''to refer to columns
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile _
& ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Open strCon
''Selecting the cell that are different
strSQL = "SELECT * FROM [Sheet1$] s " _
& "INNER JOIN [;Database=Z:\Documents\Database\Database1.mdb;].Table1 t " _
& "ON s.id=t.id " _
& "WHERE s.Field1<>t.Field1"
rs.Open strSQL, cn, 1, 3 ''adOpenKeyset, adLockOptimistic
''Just to see
''If Not rs.EOF Then MsgBox rs.GetString
''Editing one by one (slow)
rs.MoveFirst
Do While Not rs.EOF
rs.Fields("t.Field1") = rs.Fields("s.Field1")
rs.Update
rs.MoveNext
Loop
''Batch update (faster)
strSQL = "UPDATE [;Database=Z:\Documents\Database\Database1.mdb;].Table1 t " _
& "INNER JOIN [Sheet1$] s " _
& "ON s.id=t.id " _
& "SET t.Field1=s.Field1 " _
& "WHERE s.Field1<>t.Field1 "
cn.Execute strSQL
End Sub
Reading data from Access to Excel GetMDB() macro works fine, But when I tried to update the data from Excel to Access, code gives me following error:
Run-time error '3021':
Either BOF or EOF is True, or the current record has been deleted.
Requested operation requires a current record.
I checked the mdb, xlsx and sheet path and names are correct. Anyone got a similar problem as well and how to overcome? Thanks.
You cannot run UPDATE queries using Excel workbook sources as any SQL queries using workbooks are read-only from last saved instance and cannot be updated. Excel simply is not a database to do such transactions with no record-level locking mechanism, read/write access, or relational model. Though you can run append (INSERT INTO ... SELECT *) and make-table queries (SELECT * INTO FROM ...), you cannot run UPDATE that aligns to live values.
However, you can read in an Access recordset and iterate through the Excel cells aligning by ID matches. Below assumes the Excel Sheet's ID column is in Column A and Field1 is in Column B.
Dim accConn As Object, accRST As Object
Dim accFile As String, accStr As String
Dim lastrow As Long, i As Long
Const adOpenKeyset = 1, adLockOptimistic = 3, adCmdTableDirect = 512
lastrow = Workbooks(1).Sheets(1).Cells(Workbooks(1).Sheets(1).Rows.Count, "A").End(xlUp).Row
accFile = "Z:\Documents\Database\Database1.mdb"
accStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & accFile & ";"
Set accConn = CreateObject("ADODB.Connection")
Set accRST = CreateObject("ADODB.Recordset")
accConn.Open accStr
accRST.Open "SELECT * FROM Table1", accConn, adOpenKeyset, adLockOptimistic, adCmdTableDirect
If Not (accRST.BOF And accRST.EOF) Then
accRST.MoveFirst
Else
Msgbox "No records in Access table.", vbInformation
accRST.Close: accConn.Close: Set accRST = Nothing: Set accConn = Nothing
Exit Sub
End If
Do While Not accRST.EOF
For i = 1 to lastrow
If accRST!ID = Workbooks(1).Sheets(1).Range("A" & i) _
And accRST!Field1 <> Workbooks(1).Sheets(1).Range("B" & i) Then
accRST!Field1.Value = Workbooks(1).Sheets(1).Range("B" & i)
End If
Next i
accRST.Update
accRST.MoveNext
Loop
accRST.Close: accConn.Close
Set accRST = Nothing: Set accConn = Nothing
Notes:
If IDs between Excel worksheet and Access table are not one-to-one (i.e., Excel has multiple rows of same ID), the last Field1 value following the If logic will be inserted to corresponding Access row.
Above may be extensive processing if database rows and Excel cells are large. The best option is simply to use Access for all data entry/management and avoid the update needs. Since Excel is a flatfile, consider using it as the end use application and Access as central data repository.
I am getting error 3705 after adding the line
[MTSU_Data].[Tool no]=" CInt(WsInput.Range("J" & c).value) & ";"
The highlighted line where the error occurs is at
.ActiveConnection = conn
Full code
Dim conn As ADODB.Connection
Dim Accdata As ADODB.Recordset
Dim Accfield As ADODB.Field
Dim wsQueryR As Worksheet, wsFinal As Worksheet
Set wsFinal = Worksheets("Final")
Set conn = New ADODB.Connection
Set Accdata = New ADODB.Recordset
conn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\Users\wongki7\Desktop\MTSU Db.accdb;"
conn.Open
'G:\BusUnits\MTSU\MTSU\Mold Tool Set Up\MTSU Reports\Shift Reports\MTSU Db.accdb;"
' On Error GoTo CloseConnection
For c = 2 To WsInput.Range("J" & Rows.Count).End(xlUp).Row
With Accdata
.ActiveConnection = conn
.Source = "SELECT * FROM [MTSU_Data] Where [MTSU_Data].[Date]>= #" _
& Format(CDate(WsInput.Range("A2").value), "mm/dd/yyyy") & " # AND [MTSU_Data].[Date]<= #" _
& Format(CDate(WsInput.Range("A3").value), "mm/dd/yyyy") & " # AND [MTSU_Data].[LT] = " _
& CInt(WsInput.Range("M2").value) & " AND [MTSU_Data].[Tool no]=" _
& CInt(WsInput.Range("J" & c).value) & ";"
.LockType = adLockReadOnly
'.CursorType = adOpenForwardOnly
.Open
End With
Next
Worksheets("Result").Select
Sheets("Result").Range("a2").CopyFromRecordset Accdata
Accdata.Close
conn.Close
Any help is appreciated. Thanks and have a good day ahead.
Can you not try to move the line
.ActiveConnection = conn
To outside the loop. Obviously fully qualifying it..
Accdata.ActiveConnection = conn
That looks to me that you are trying to make the connection for each iteration and I think it is only necessary once... maybe.
To best fit your code, Id try something like:
Sub SomeRoutine()
Dim conn As ADODB.Connection
Dim Accdata As ADODB.Recordset
Dim Accfield As ADODB.Field
Dim wsQueryR As Worksheet, wsFinal As Worksheet
Dim c As Long
Set wsFinal = Worksheets("Final")
Set conn = New ADODB.Connection
Set Accdata = New ADODB.Recordset
conn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\Users\wongki7\Desktop\MTSU Db.accdb;"
conn.Open
Accdata.ActiveConnection = conn
Accdata.LockType = adLockReadOnly
For c = 2 To WsInput.Range("J" & Rows.Count).End(xlUp).Row
Call Accdata.Open("SELECT * FROM BLah Blah")
Sheets("Result").Range("a2").CopyFromRecordset Accdata
Accdata.Close
Next
conn.Close
End Sub
You may be able to look at the way you build the SQL request to build a query to get the data in one go and and do a single paste to Excel with the CopyFromRecordset.... but that's a different issue.
A mistake I've made many times before. When assigning objects, you need to use Set. Change the line to
Set .ActiveConnection = conn
.Source and .LockType are scalar properties, so they don't need Set, but .Activeconnection does.
I need to get my table up in the powerpivot model down to the excel worksheet.
So far I have tried to use a Recordset but I cant get an ActiveConnection to the powerpivot table. Is it possible? Or is there an other better way to do this?
I use the following code:
Dim name As ADODB.Recordset
Set name = New ADODB.Recordset
With name
.ActiveConnection = ConnectionName
.Source = "TableName"
.LockType = adLockReadOnly
.CursorType = adOpenForwardOnly
.Open
End With
But with this piece of code I get an error at .ActiveConnection. (Run-time error 3001, it complains about non-allowed connection interval)
This is an example of how to read the records from a named range (assuming 'TableData' is named range).
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Set cn = New ADODB.Connection
Set rs = New ADODB.Recordset
With cn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";" & _
"Extended Properties=Excel 8.0;"
.Open
End With
rs.Open "SELECT * FROM [TableName]", cn
Dim r
For Each r In rs.GetRows
'Do whatever you want per record
Debug.Print r
Next r
rs.Close
cn.Close
We are frequently using some Excel files as a datasource for massive imports in our database. At the code level, we always refer to the corresponding data source as:
set rs = New ADODB.recordset
rs.open "SELECT * FROM [sheet1$]", myConnectionString, etc
Of course, this procedure only works when there's a sheet in the Excel file which is named [sheet1]. I'd like to add some sheet management code here, but without having to create an instance of the original Excel file, opening it, and so on (my users might get a file with a different sheet name, and might not have Excel installed).
Any idea?
You can open a recordset with the ADO OpenSchema method and then list the table (sheet) names in your workbook.
Public Sub SheetsInWorkbook()
Dim strConnect As String
Dim cn As Object
Dim rs As Object
Dim strPath As String
strPath = CurrentProject.Path & Chr(92) & "temp.xls"
strConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Data Source='" & strPath & "';" _
& "Extended Properties='Excel 8.0';"
Set cn = CreateObject("ADODB.Connection")
cn.ConnectionString = strConnect
cn.Open
Set rs = cn.OpenSchema(20) '20 = adSchemaTables '
Debug.Print "TABLE_NAME"
Do While Not rs.EOF
Debug.Print rs!TABLE_NAME
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub