Using select query on access database - database

first i was trying to use execute with select query which returns error type mismatch. then after reading some toturials i found out that openrecordset is the trick.
now i am having issue with openrecordset as it is just returning the query and not the selected value. below is my code:
Dim sql As String
Dim rs As DAO.Recordset
' this will loop through each cell in column I until end
For x = 1 To NumRows
sql = "select Email from Salesforce where ID =" & ActiveCell.Value
Set rs = oDB.OpenRecordset(sql, dbOpenDynaset)
ActiveCell.Offset(0, 13).Value = rs
so ActiveCell.Offset(0, 13).Value = sql is just inserting the select Email from Salesforce where ID equals ActiveCell.Value

try using:
ActiveCell.Offset(0, 13).CopyFromRecordset rs

Related

Excel VBA Runtime 3704 Operation is not allowed when object is closed

I have been using this code for some time and it works. As a matter of fact it works with a basic query. It just does not work with my new Stored Procedure. I can run the stored procedure manually. in SSMS and get my results. I thought that the error was when I was not getting data back so I added the . . . If myRS1.EOF Then . . . still getting the 3704 runtime error.
Here is my Excel (2013) Code
Private Sub cmdOK_Click()
Dim myStartDate, myEndDate
Dim myInsuranceCode
Dim objAD, objUser
Dim myDisplayName, myLastRow
Dim myMessage, myStyle, myTitle, myResult
Dim mySQL As String
Dim myConn
Dim myCmd
Dim myRS1
Dim myRange, myNamedRange, myCheckRange As Range
Dim X, Y, z
Dim myPercent, myLowEnd, myHighEnd
Dim myValue1, myValue2, myValue3, myValue4, myValue5, myValue6, myValue7, myValue8
Dim myCheckValue
Dim myHeaderRow, myDataRow, myLastColumn
'SET THESE ACCORDING TO THE REPORT. THE FIRST TWO MIGHT NOT NEED ANY CHANGES
myHeaderRow = 2
myDataRow = 3
myLastColumn = 22
'SETUP DATABASE OBJECTS
Set myConn = New ADODB.Connection
Set myCmd = New ADODB.Command
Set myRS1 = New ADODB.Recordset
Application.StatusBar = True
Application.StatusBar = "Connecting to SQL Server"
'GET DATES FROM TEH FORM AND SET SQL STATEMENT
myStartDate = frmMain.txtStartDate
myEndDate = frmMain.txtEndDate
'RUN INSURANCE STORE PROCEDURE
'SEPERATE THE INSURANCE CODE WITH A |
myInsuranceCode = "S19|S22"
mySQL = "dbo.BMH_rpt_PATIENTS_INSURANCE_LISTING '" & myStartDate & "', '" & myEndDate & "', '" & myInsuranceCode & "'"
'mySQL = "SELECT * FROM dbo.BETHESDA_ADMIT_SOURCE"
'HIDE THE FORM
frmMain.Hide
'GET THE USER THAT IS SIGNED IN
Set objAD = CreateObject("ADSystemInfo")
Set objUser = GetObject("LDAP://" & objAD.UserName)
myDisplayName = objUser.DisplayName
'OPEN CONNECTIONS TO THE DATABASE
myConn.ConnectionString = "Provider=SQLOLEDB;Data Source=mySQLServer;Initial Catalog=myDatabaseName;User ID=user;Password=xxxxxxxx;Connection Timeout=300;"
myConn.Open
'SET AND EXECUTE SQL COMMAND
Set myCmd.ActiveConnection = myConn
myCmd.CommandText = mySQL
myCmd.CommandType = adCmdText
Application.StatusBar = "Running Stored Procedure " & mySQL
myCmd.CommandTimeout = 3000
'OPEN RECORDSET
Set myRS1.Source = myCmd
myRS1.Open
'CHECK TO MAKE SURE WE ARE NOT AT THE BOTTOM OF THE SHEET COULD MEAN THERE WAS NOT DATA LAST TIME.
'THIS SAME CODE WILL REPEAT FOR THE DATA TAB
'*********** DATA *************
'CHECK TO MAKE SURE THERE IS DATA
If myRS1.EOF Then <---- THIS IS THE LINE I AM GETTING THE ERROR
Cells(myDataRow, 1).Value = "No Data Qualifies"
myMessage = "No data qualifing for your request " & mySQL
myTitle = "No Data"
myStyle = vbCritical + vbOKOnly
myResult = MsgBox(myMessage, myStyle, myTitle)
Exit Sub
End If
'SELECT THE SHEET TO CLEAR OUT THE OLD data on DATA
'IF THIS IS NOT SET ON THE SEEHET IT WILL FAIL
Set myTable = Sheets("DATA").ListObjects("DATA")
If Cells(myDataRow, 1).Value <> "" Then
myTable.DataBodyRange.Rows.Delete
End If
'COPY THE DATA TO EXCEL
Application.StatusBar = "Copying the new data."
Sheets("DATA").Cells(myDataRow, 1).CopyFromRecordset myRS1
Cells(1048576, 1).Select
Selection.End(xlUp).Select
myLastRow = ActiveCell.Row
'Application.StatusBar = "Naming the new DATA range"
'ActiveWorkbook.Names.Add Name:=myNamedRange, RefersTo:=Range(Cells(myHeaderRow, 1), Cells(myLastRow, myLastColumn))
myTable.Resize Range(Cells(myHeaderRow, 1), Cells(myLastRow, myLastColumn))
End Sub
*** This is all the VBA Code now. It is failing on the myRS1.EOF line so none of the other code even runs.
As you can see I have two mySQL statements. The first one is not working, but the second one works no issue.
If I run the SP from SSMS or even take the mySQL that is generated it runs fine in SSMS.
Here is the SP
--EXAMPLE
-- dbo.BMH_rpt_PATIENTS_INSURANCE_LISTING '11/01/2020', '11/30/2020', 'S19|S22'
ALTER PROCEDURE [dbo].[BMH_rpt_PATIENTS_INSURANCE_LISTING]
#StartDate AS DATETIME,
#EndDate AS DATETIME,
#Insurance AS VARCHAR(MAX)
AS
/** GET THE INSURANCE CODES **/
SELECT VALUE
INTO #INSURANCE
FROM STRING_SPLIT(#Insurance, '|')
/** GET THE PATIENTS FOR THE LIST **/
SELECT vv.pt_id AS 'Patient Account',
vv.alt_med_rec_no AS 'MRN'
FROM smsdss.vst_v AS vv
WHERE vv.pyr_cd IN (SELECT * FROM #INSURANCE)
AND vv.start_full_date BETWEEN #StartDate AND #EndDate
AND vv.tot_bal_amt <> 0

EXCEL VBA to SQL Index and Seek

I am exporting data in Excel table to SQL Server Database, If exists UPDATE else INSERT.
The following VBA code works well for exporting to ACCESS Database,
BUT NOT TO SQL SERVER DATABASE TABLE.
Error Message appear :Invalid Use of Property for .Index and .Seek.
Please Help !!! Toh
Sub ExcelDataToSql ()
Dim cn As ADODB.Connection, rs As ADODB.Recordset, r As Long
Dim lastrow As Long, o As Long
Set cn = New ADODB.Connection
Set rs = New ADODB.Recordset
cn.Open "Provider=SQLNCLI11;Server=***;Database=****;Trusted_Connection=yes;"
rs.CursorLocation = adUseServer
rs.Open "InventorySQL", cn, 1, 3, adCmdTableDirect
' Get Lastrow
Worksheets("InventoryEXCEL").Select
lastrow = Worksheets("InventoryEXCEL").Cells(rows.Count, 1).End(xlUp).Row
r = 2 ' the start row in the worksheet
For o = 2 To lastrow
'Check For Duplicate In Database SQL
With rs
.Index = "PrimaryKey"
.Seek Range("A" & r).Value
If .EOF Then
.AddNew
'If No Duplicate insert New Record
rs.Fields("oPartno") = Range("A" & r).Value
rs.Fields("oDesc") = Range("B" & r).Value
rs.Fields("oCost") = Range("C" & r).Value
.update
Else
' If Duplicate Found Update Existing Record
rs.Fields("oDesc") = Range("B" & r).Value
rs.Fields("oCost") = Range("C & r).Value
.Update
End If
End With
Next o
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
MsgBox "Posting Completed"
End Sub
. Index = "PrimaryKey" --- Sysntax Error : Invalid Use of Property
.Seek Range ("A" & r).Value Sysntax Error :
Reference:Seek Method and Index Property Example (VB)
The MSDN example passes an Array as the first parameter.
rstEmployees.Seek Array(strID), adSeekFirstEQ
The first parameter's name os KeyValues which also implies an array
I would try this first
.Seek Array(Range("A" & r).Value)
It might also be beneficial to use one of the SeekEnum value
Update: TOH the OP found that this was the relavent code snippet
MSDN also suggest checking if the Provider supports .Index and .Seek
If rstEmployees.Supports(adIndex) And rstEmployees.Supports(adSeek) Then
My Problem is resolved by work around.
Many resources indicated that Sql Providers do not support the index and seek function. So I avoid Index and Seek
I work around by importing the excel worksheet into Sql server as source table... thereafter Merge the target table with source table... if match UPDATE, if Not Match INSERT.
select * from InventoryTableSQL
select * from InventoryTableFromExcel
Merge InventoryTableSQL as T
using InventoryTableFromExcel as S
on t.oPartno = s.oPartno
when matched then
update set t.oPartno = s.oPartno,
t.oDesc = s.oDesc,
t.oCost = s.oCost
when not matched by target then
insert(oPartno, oDesc, oCost) values(s.oPartno, s.oDesc, s.oCost));

Extract Data from Sql and display to excel using vba

I am trying to join data from two sql tables. Table1 should have columns FileID, AccName, number,ut _score,uw_score
Table 2 should have columns FileID , label, data(contains y/N answers) and AdditionalComments. There are list of questions displayed under column Label. I need to look into last three questions(under the column LABEL) and post the result only if the answers are No
Both these tables can be identified with the unique file id, that is associated with every accountname. So I need to join the table that has only the columns as mentioned above.
Option Explicit
Sub GetDataFromADO()
'Declare variables'
Dim objMyConn As ADODB.Connection
Dim objMyCmd As ADODB.Command
Dim objMyRecordset As ADODB.Recordset
Dim iCols As Integer
Dim tbl As ListObject
Set objMyConn = New ADODB.Connection
Set objMyCmd = New ADODB.Command
Set objMyRecordset = New ADODB.Recordset
'Open Connection'
objMyConn.ConnectionString = "Provider=SQLOLEDB;Data Source= .;Initial Catalog=.;Trusted_connection=Yes;Integrated Security=SSPI;"
objMyConn.Open
'Dim sSqL As String
'Set objMyCmd.ActiveConnection = objMyConn
'sSqL = "Select FileID, AccName, number,ut _score,uw_score from AUT.dbo.LIST"
'objMyConn.Execute sSqL
'Set and Excecute SQL Command'
Dim u As String
Set objMyCmd.ActiveConnection = objMyConn
objMyCmd.CommandText = "select AccName, Underwriter, Auditor,UT_Score,Underwriter_Score from Actuarial.dbo.Audit_Checklist"
objMyCmd.CommandText = "Select Label, Data, AdditinalComments from Actuarial.dbo.List_data"
objMyCmd.CommandType = adCmdText
objMyCmd.Execute
'Open Recordset'
Set objMyRecordset.Source = objMyCmd
objMyRecordset.Open
For iCols = 0 To objMyRecordset.Fields.Count - 1
Worksheets("Data").Cells(1, iCols + 1).Value = objMyRecordset.Fields(iCols).name
Next
'Copy Data to Excel'
Worksheets("Data").Range("A2").CopyFromRecordset objMyRecordset
End Sub
Here is the sql query, that I need to include conditions to select last 6 values from the Label column of table 2. Kindly apologize for the naive where clause that i used. Appreciate any help on this !
SELECT Reports.dbo.tbl1.AccName,Reports.dbo.tbl1.Underwriter,
Reports.dbo.tbl1.Auditor, Reports.dbo.tbl1.UT_Score,
Reports.dbo.tbl1.Underwriter_Score, Reports.dbo.tbl2.Label,Reports.dbo.tbl2.Data, Reports.dbo.tbl2.AdditinalComments
FROM Reports.dbo.tbl1
INNER JOIN Reports.dbo.tbl2
ON Reports.dbo.tbl1.FileID=Reports.dbo.tbl2.FileID;
Where Reports.dbo.tbl2.Label='Is it profitable?' OR 'When is effective date expiring ? ' OR 'Did the community accept?';
**Output that I get now **
Expected Result

Excel VBA - SQL Call - Operation is not allowed when the object is closed

I have a couple macros to make calls to SSMS 2014 to run a query and return the results in a defined cell in my worksheet. They work successfully, but when I try to use certain queries with temp tables I get the following error message:
I have researched online and the best answer I can find is to add SET NOCOUNT ON at the beginning of my query. I tried that, and still got the same message.
The piece of code that the Debug brings me to is as follows:
bqr.Range("B6").CopyFromRecordset rst
The meat and potatoes of my code, along with the variable setups that matter, is as follows:
Dim cnn As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim ConnectionString As String
Dim StrQuery As String
Dim SOURCE As String
Dim DATABASE As String
Dim QUERY As String
Dim intColIndex As Integer
Dim sDate As String
Dim eDate As String
Dim qt As Worksheet
Dim qtr As Worksheet
Dim bqr As Worksheet
Dim bp As Worksheet
ConnectionString = "Provider=SQLOLEDB;Data Source=" & SOURCE & "; Initial Catalog=" & DATABASE & "; Integrated Security=SSPI;"
cnn.Open ConnectionString
cnn.CommandTimeout = 900
StrQuery = QUERY
rst.Open StrQuery, cnn
bqr.Range("B6").CopyFromRecordset rst
For intColIndex = 0 To rst.Fields.Count - 1
Range("B5").Offset(0, intColIndex).Value = rst.Fields(intColIndex).Name
Next
The most confusing part is that the error suggests that my rst recordset is closed, even though it is opened just before I use the CopyFromRecordset
I've tried adding DROP TABLE at the end of my query, the SET NOCOUNT ON function at the beginning, and even tested some smaller simple temp tables as tests.
For example, I set my QUERY variable to:
QUERY = "CREATE TABLE #Test1 (TestID INT, TestValue VARCHAR(20))"
QUERY = QUERY + " INSERT INTO #Test1"
QUERY = QUERY + " VALUES (1, 'Pass'), (2, 'Fail'), (3, 'Try Again')"
QUERY = QUERY + " SELECT * INTO #Test2 FROM #Test1 WHERE TestID = 1"
QUERY = QUERY + " SELECT * FROM #Test2"
Then ran the code to extract and past into Excel, and it worked.
Therefore, I am stumped. Maybe there is a limit to how long the query can be? Right now it's 180 lines long, so it's pretty big...
Any suggestions are appreciated!
EDIT: Full macro below (less the actual query):
Private Sub CommandButton1_Click()
If TextBox1.Value = "i.e. 20160101" Or TextBox2.Value = "i.e. 20160131" Then
MsgBox "Please fill out all fields before proceeding"
ElseIf Len(TextBox1.Value) <> 8 Or Len(TextBox2.Value) <> 8 Or Not IsNumeric(TextBox1.Value) Or Not IsNumeric(TextBox2.Value) Then
MsgBox "Please use correctly formatted Datekeys (i.e. yyyymmdd)"
Else
Application.DisplayAlerts = False
Sheets(ActiveWorkbook.Sheets.Count).Select
While ActiveSheet.Name <> "[worksheet I want to keep]"
ActiveSheet.Delete
Sheets(ActiveWorkbook.Sheets.Count).Select
Wend
Dim cnn As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim ConnectionString As String
Dim StrQuery As String
Dim SOURCE As String
Dim DATABASE As String
Dim QUERY As String
Dim intColIndex As Integer
Dim sDate As String
Dim eDate As String
Dim qtr As Worksheet
Dim bqr As Worksheet
Dim bp As Worksheet
Set qtr = Sheets([sheet name])
Sheets.Add after:=qtr
Set bqr = ActiveSheet
bqr.Name = "[sheet name]"
Sheets.Add after:=bqr
Set bp = ActiveSheet
bp.Name = "[sheet name]"
SOURCE = "[server]"
DATABASE = "[database]"
sDate = UserForm1.TextBox1.Value
eDate = UserForm1.TextBox2.Value
QUERY = "[beginning of query]"
QUERY = QUERY + " [more query here]" 'This gets repeated a lot for each additional line in the query'
qtr.Select
Range("B6").Select
While ActiveCell.Value <> ""
QUERY = QUERY + " " + ActiveCell.Value
ActiveCell.Offset(1, 0).Select
Wend
QUERY = QUERY + " [more query here]" 'This gets repeated a lot for the remaining lines in the query'
ConnectionString = "Provider=SQLOLEDB;Data Source=" & SOURCE & "; Initial Catalog=" & DATABASE & "; Integrated Security=SSPI;"
cnn.Open ConnectionString
cnn.CommandTimeout = 2000
StrQuery = QUERY
rst.Open StrQuery, cnn
bqr.Range("B6").CopyFromRecordset rst
For intColIndex = 0 To rst.Fields.Count - 1
Range("B5").Offset(0, intColIndex).Value = rst.Fields(intColIndex).Name
Next
End If
Application.DisplayAlerts = True
End Sub
Start your T-SQL query with set nocount on;
QUERY = "set nocount on;"
QUERY = QUERY & "declare #Test1 table (TestID INT, TestValue VARCHAR(20))"
QUERY = QUERY & " INSERT INTO #Test1"
QUERY = QUERY & " VALUES (1, 'Pass'), (2, 'Fail'), (3, 'Try Again')"
QUERY = QUERY & " SELECT * FROM #Test1 WHERE TestID = 1"
Then it should work. The next example will also work and is a bit closer to your example (yet using table variables).
set nocount on;
declare #Test1 table (TestID INT, TestValue VARCHAR(20))
declare #Test2 table (TestID INT, TestValue VARCHAR(20))
INSERT INTO #Test1
VALUES (1, 'Pass'), (2, 'Fail'), (3, 'Try Again')
insert into #Test2
select *
from #Test1 WHERE TestID = 1
select * from #Test2

Work around 'IN' clause limitation

I am trying to write a macro to query from our database using the IN clause except with one problem. I am reaching the limit of the IN clause for SQL Server.
My macro looks like this:
Dim row_count As Double
row_count = ActiveSheet.UsedRange.Rows.Count - 1
half_row_count = row_count
Dim i As Double
Dim products As String
For i = 2 To half_row_count
Dim product_id As String
product_id = Cells(i, 1).Value
'test = sixtyDays(product_id, conn)
'Cells(i, 10).Value = test
products = products & "'" & product_id & "'" & ", "
Next i
Dim sample As New ADODB.Recordset
products = Left(products, Len(products) - 2)
Set sample = sixtyDays(products, conn)
Sheets(1).Range("K2").CopyFromRecordset sample
conn.Close
Function sixtyDays(ProductID As String, new_conn As ADODB.Connection) As ADODB.Recordset
Dim sConnString As String
Dim rst As New ADODB.Recordset
Dim recordsAffecfted As Long
StrQuery = "SELECT ProductAnalysisByMonth.SalesQty FROM ProductAnalysisByMonth WHERE ProductAnalysisByMonth.ProductID IN (" + ProductID + ") AND ProductAnalysisByMonth.Month = " + CStr(Month(Date) - 2)
rst.Open StrQuery, new_conn
Set sixtyDays = rst
End Function
So I need to some how split the query into smaller chunks, except, the number of arguments passed to the SQL query will vary from week to week.
What is the most efficient way of handling this problem?
Create a table function that will return your string results into a data-set that can be inserted into a CTE, temp table, or used directly in a join. This has been the most effective way for me to get around this limitation. Below is a link to Ole Michelsen's website who provides a simple but flexible solution.
Link: http://ole.michelsen.dk/blog/split-string-to-table-using-transact-sql.html

Resources