SQL Code and VBA

Question

I have used this site before (and various others) and subsequently I have built something that usually works. It now isnt working with a new SQL script (but the SQL script does work!). Please note I am not good with VBA code and dont really understand it....!!!

Can someone help please? I get the error "Run-time error '3704' , Operation isnot allowed when the object is close"). I dont understand how it has closed before finishing!

I have two sections to this: Module 1 - contains the connection properties Module 2 - contains the SQL code to run Both below:

Module 1:

Public Const DBName As String =
Public Const strServer As String = "RMSSQL"
Public Const connecString1 As String = "Provider=SQLOLEDB.1"
Public Const connecString2 As String = ";Initial Catalog="
Public Const connecString3 As String = ";DataSource="
Public passSQL As ADODB.Connection
Public myrst As ADODB.Recordset

Public Function runTheQuery(sqlQuery, DBaseName)
    'connect
    Dim strConnect As String
    strConnect = "Driver={SQL Server}; Server=" & strServer & ";Database=" & DBaseName & ";Trusted_Connection=yes; "

    Set passSQL = New ADODB.Connection
    passSQL.ConnectionString = strConnect
    passSQL.CursorLocation = adUseClient
    passSQL.CommandTimeout = 0
    passSQL.Open

    'create recordset
    Dim aRst As ADODB.Recordset
    Set aRst = New ADODB.Recordset
    With aRst
    .activeconnection = passSQL
    .CursorLocation = adUseClient
    .CursorType = adOpenStatic
    .LockType = adLockBatchOptimistic

    'run sql query
    .Open sqlQuery
    .activeconnection = Nothing

    End With
    Set myrst = aRst

    'close
    passSQL.Close
End Function    

Module 2:

Sub simplequery()
    runTheQuery "declare @Portname varchar(60) " & _
            "set @Portname = " & "'" & Range("G10").Value & "'" & _
            "SELECT SUM(M.TIV) as TIV " & _
            "FROM (select port.PORTNAME,  lcvg.LOCID, lcvg.LOSSTYPE, prop.OCCSCHEME, prop.OCCTYPE, MAX(lcvg.VALUEAMT) TIV " & _
            "from accgrp ac " & _
    "inner join Property prop on prop.ACCGRPID = ac.ACCGRPID " & _
    "inner join Address addr on addr.AddressID = prop.AddressID " & _
    "inner join loccvg lcvg on lcvg.LOCID = prop.LOCID " & _
    "inner join portacct pa on pa.ACCGRPID = ac.ACCGRPID " & _
    "inner join portinfo port on port.PORTINFOID = pa.PORTINFOID " & _
    "where port.PORTNAME = @Portname " & _
    "group by port.PORTNAME,  lcvg.LOCID, lcvg.LOSSTYPE, prop.OCCSCHEME, prop.OCCTYPE, lcvg.VALUEAMT) M " & _
    "GROUP BY M.PORTNAME; ", Sheets("Modelled Results - 1 of 2").Range("g9").Value

    Sheets("DataDumps").Range("A1").Select

    'Headers
    For col = 0 To myrst.Fields.Count - 1
        ActiveCell.Offset(0, col).Value = myrst.Fields(col).Name
    Next

    'Paste recordset
    Range("A1").CopyFromRecordset myrst
End Sub 

When I debug, it is this that is highlighted:

'Paste recordset
Range("A1").CopyFromRecordset myrst

UPDATED to this:

Module 1:

'Public Const DBName As String =
Public Const strServer As String = "RMSSQL"
Public Const connecString1 As String = "Provider=SQLOLEDB.1"
Public Const connecString2 As String = ";Initial Catalog="
Public Const connecString3 As String = ";DataSource="
Public passSQL As ADODB.Connection
Public myrst As ADODB.Recordset

Function runTheQuery(ByVal SQLQuery As String, ByVal DBName As String, ByRef MyRange As Range)

'Connect
Dim strConnect As String
strConnect = "Driver={SQL Server}; Server=" & strServer & ";Database=" & DBaseName & ";Trusted_Connection=yes; "

Set passSQL = New ADODB.Connection
passSQL.ConnectionString = strConnect
passSQL.CursorLocation = adUseClient
passSQL.CommandTimeout = 0
passSQL.Open

'create recordset
Dim aRst As ADODB.Recordset
Set aRst = New ADODB.Recordset
With aRst
.activeconnection = passSQL
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockBatchOptimistic



'run sql query
.Open SQLQuery
.activeconnection = Nothing


End With
Set myrst = aRst

'close
passSQL.Close

Sheets("DataDumps").Range("A1").Select
'Headers
For col = 0 To myrst.Fields.Count - 1
ActiveCell.Offset(0, col).Value = myrst.Fields(col).Name
Next

'Paste recordset
Range("A1").CopyFromRecordset myrst

MyRange.CopyFromRecordset myrst
myrst.Close

End Function

Module 2: Sub simplequery()

runTheQuery "declare @Portname varchar(60) " & _
        "set @Portname = " & "'" & Range("G10").Value & "'" & _
        "SELECT SUM(M.TIV) as TIV " & _
        "FROM (select port.PORTNAME,  lcvg.LOCID, lcvg.LOSSTYPE, prop.OCCSCHEME, prop.OCCTYPE, MAX(lcvg.VALUEAMT) TIV " & _
        "from accgrp ac " & _
"inner join Property prop on prop.ACCGRPID = ac.ACCGRPID " & _
"inner join Address addr on addr.AddressID = prop.AddressID " & _
"inner join loccvg lcvg on lcvg.LOCID = prop.LOCID " & _
"inner join portacct pa on pa.ACCGRPID = ac.ACCGRPID " & _
"inner join portinfo port on port.PORTINFOID = pa.PORTINFOID " & _
"where port.PORTNAME = @Portname " & _
"group by port.PORTNAME,  lcvg.LOCID, lcvg.LOSSTYPE, prop.OCCSCHEME, prop.OCCTYPE, lcvg.VALUEAMT) M " & _
"GROUP BY M.PORTNAME ", Sheets("Modelled Results - 1 of 2").Range("g9").Value, Range("a1")

End Sub

Answer 1

The problem here is runTheQuery closes the recordset, as its last action. You cannot import records from a closed recordset. There are a couple of ways you can fix this.

Solution 1

Pass the range object to runTheQuery, and perform paste there.

Function runTheQuery (ByVal SQLQuery AS String, ByVal DBName AS String, ByRef MyRange AS Range)

    ' Code as before.

    ' New code at end of function.
    MyRange.CopyFromRecordset myrst
    myrst.Close
End Function

You would now call runTheQuery like this runTheQuery "SELECT...", "MyDb", Range("A1").

Soultion 2

Break runTheQuery into a number of functions:

1. OpenRecordset
2. RunQuery
3. CloseRecordset

You would call OpenRecordset first. Call RunQuery as needed. Finally call CloseRecordset when you no longer need the content.

EDIT

Added working example, as per OP request.

Below is my version of your code. I've removed a few lines that I felt weren't adding any value. But you could add them back in if you feel differently (everything should work fine with or without). I've also changed the function to a sub, as it does not return anything. Again this will not change how the code works, it's just tidier.

As it stands this code is ok but could be better. I read years ago that any VBA proceedure longer than one screen is too long. I've always found that to be a useful rule. Smaller subs/funcs are easier to read, understand and debug, even if you end up with more of them. As you get more confident with VBA, see if you split this into several logical steps, perhaps all called in sequence from another sub. This will make it easier to turn features on and off (for example you might not always want a header row). Finally I've added the optional statement Option Explicit. This prevents your code from calling variables that haven't been declared. Always good practice.

Option Explicit
Public Const strServer As String = "RMSSQL"     ' Name of SQL Server to connect to.

Public Sub runTheQuery(ByVal SQLQuery As String, ByVal DBName As String, ByRef MyRange As Range)
' Copies a SQL result set into an Excel workbook.
'   SQLQuery    - Valid SQL statement to be executed.
'   DBName      - Name of database to execute SQL query on.
'   MyRange     - Top left cell to paste results into.

Dim passSQL As ADODB.Connection ' Connection to SQL Server.
Dim myrst As ADODB.Recordset    ' Used to execute query and hold results.
Dim col As ADODB.Field          ' Used to import header row.
Dim i As Integer                ' Used to count fields, when importing header.


    ' Ready objects for use.
    Set passSQL = New ADODB.Connection
    Set myrst = New ADODB.Recordset

    ' Connect to SQL Server.
    With passSQL
        .ConnectionString = "Driver={SQL Server}; Server=" & strServer & ";Database=" & DBName & ";Trusted_Connection=yes;"
        .CommandTimeout = 0     ' Prevents large queries from timing out.  Perhaps not needed?
        .Open
    End With

    ' Execute query.
    With myrst
        .ActiveConnection = passSQL
        .Open SQLQuery
    End With


    ' Import results, if there are any.
    If Not myrst.EOF Then

        ' Import header into first row.
        ' Count fields to offset from top left cell, across one.
        For Each col In myrst.Fields

            MyRange.Offset(0, i).Value = col.Name
            i = i + 1
        Next

        MyRange.Offset(1, 0).CopyFromRecordset myrst    ' Paste results after header (offset).
    Else

        MsgBox "The query did not return any records", vbExclamation, "Query Warning"
    End If


    ' Close and release object vairables before they leave scope.
    ' You must close the recordset first, as it replies on an open connection.
    myrst.Close
    passSQL.Close

    Set myrst = Nothing
    Set passSQL = Nothing
End Sub

To call this code:

Sub simplequery()
' Imports the results of a SQL query.
Dim DbName As String

    ' Get the database name.
    DbName = Sheets("Modelled Results - 1 of 2").Range("g9").Value

    ' Import query.
    runTheQuery "<Your SQL Query Here>", DbName, Sheets("DataDumps").Range("A1")
End Sub

As you can see this sub doesn't do very much anymore. All the work has been moved into runTheQuery.

Answer 2

You closed the connection at the bottom of module 1. Record sets require getting connection to stay open.