Код SQL и VBA

Question

Я использовал этот сайт раньше (и других), и впоследствии я создал что-то, что обычно работает. Теперь он не работает с новым SQL-скриптом (но SQL-скрипт работает!). Обратите внимание, что я плохо разбираюсь в коде VBA и не понимаю его .... !!!

Может кто-то помочь, пожалуйста? Я получаю сообщение об ошибке «Ошибка времени выполнения» 3704, операция не разрешена, когда объект близок »). Я не понимаю, как он закрылся до окончания!

У меня есть два раздела к этому: Модуль 1 - содержит свойства соединения Модуль 2 - содержит код SQL для запуска И ниже:

Модуль 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  

Модуль 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 

Когда я отладки, именно это подсвечивается:

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

ОБНОВЛЕНО к этому:

Модуль 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 

Модуль 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

Вы закрыли соединение в нижней части модуля 1. Для набора записей требуется, чтобы соединение оставалось открытым.

Answer 2

Проблема здесь runTheQuery закрывает набор записей, как его последнее действие. Вы не можете импортировать записи из закрытого набора записей. Есть несколько способов исправить это.

Раствор 1

Pass объект диапазона для runTheQuery, а также выполнять пасту там.

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 

Теперь вы назвали бы runTheQuery как этот runTheQuery "SELECT...", "MyDb", Range("A1").

Soultion 2

Перерыв runTheQuery в ряд функций:

1. OpenRecordset
2. RunQuery
3. CloseRecordset

Вы назвали бы OpenRecordset первым.Позвоните по телефону RunQuery по мере необходимости. Наконец, звоните CloseRecordset, когда вам больше не нужен контент.

EDIT

Добавлен рабочий пример, согласно запросу OP.

Ниже приведена моя версия вашего кода. Я удалил несколько строк, которые, по моему мнению, не добавляли никакой ценности. Но вы можете добавить их обратно, если вы чувствуете себя по-другому (все должно нормально работать с или без). Я также изменил function to a sub, так как он ничего не возвращает. Опять же, это не изменит, как работает код, это просто более аккуратно.

Поскольку он стоит, этот код в порядке, но может быть лучше. Я много лет назад читал, что любой VBA-процесс длится более одного экрана слишком долго. Я всегда считал это полезным правилом. Меньшие субтитры/функции легче читать, понимать и debug, даже если в итоге их больше. По мере того, как вы будете более уверенны в VBA, посмотрите, разделите ли вы это на несколько логических шагов, возможно, все вызваны в последовательности из другого суб. Это упростит включение и отключение функций (например, вы не всегда можете использовать строку заголовка). Наконец, я добавил необязательный оператор Option Explicit. Это не позволяет вашему коду вызывать переменные, которые не были объявлены. Всегда хорошая практика.

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 

Для вызова этого кода:

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 

Как вы можете видеть, этот сабвуфер не делает очень больше. Вся работа была перенесена в runTheQuery.