SQL代码与VBA

我以前使用过这个网站（以及其他各种网站），后来我建立了一些通常有效的网站。它现在不使用新的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    

'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

    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

调试时，突出显示的是以下内容：

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

更新为：

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

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    

'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: 次单纯形（）

---

您关闭了模块1底部的连接。记录集需要获取连接才能保持打开状态

您关闭了模块1底部的连接。记录集需要获取连接才能保持打开状态

这里的问题是

运行查询

关闭记录集，作为其最后一个操作。无法从关闭的记录集中导入记录。有几种方法可以解决这个问题

解决方案1

将范围对象传递给

运行查询

，然后在那里执行粘贴

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”）

SOUTION 2

将

运行查询

分解为多个函数：

开放记录集

运行查询

封闭记录集

您可以先调用

OpenRecordset

。根据需要调用

RunQuery

。当您不再需要内容时，最后调用

CloseRecordset

编辑

根据OP请求添加了工作示例

下面是我的代码版本。我删除了一些我觉得没有任何价值的行。但是如果你感觉不一样的话，你可以把它们加回去（不管有没有，一切都应该很好）。我还更改了，因为它不返回任何内容。同样，这不会改变代码的工作方式，只是更整洁而已

目前来看，这段代码还可以，但可能更好。几年前我读过一篇文章，说任何超过一个屏幕的VBA程序都太长了。我一直觉得这是一条有用的规则。更小的sub/func更易于阅读、理解和使用，即使最终拥有更多sub/func。当您对VBA更加自信时，请查看是否将其拆分为几个逻辑步骤，可能所有步骤都是从另一个子系统按顺序调用的。这样可以更容易地打开和关闭功能（例如，您可能并不总是需要标题行）。最后，我添加了可选语句。这将防止代码调用尚未声明的变量。总是良好的实践

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

Sub-simplequery（）
'导入SQL查询的结果。
Dim DbName作为字符串
'获取数据库名称。
DbName=图纸（“建模结果-1/2”）.范围（“g9”）.值
'导入查询。
运行查询“”，数据库名，工作表（“数据转储”）。范围（“A1”）
端接头

---

正如你所看到的，这艘潜艇不再有很多功能了。所有工作都已移至

运行查询

这里的问题是

运行查询

关闭记录集，作为其最后一个操作。无法从关闭的记录集中导入记录。有几种方法可以解决这个问题

解决方案1

将范围对象传递给

运行查询

，然后在那里执行粘贴

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”）

SOUTION 2

将

运行查询

分解为多个函数：

开放记录集

运行查询

封闭记录集

您可以先调用

OpenRecordset

。根据需要调用

RunQuery

。当您不再需要内容时，最后调用

CloseRecordset

编辑

根据OP请求添加了工作示例

下面是我的代码版本。我删除了一些我觉得没有任何价值的行。但是如果你感觉不一样的话，你可以把它们加回去（不管有没有，一切都应该很好）。我还更改了，因为它不返回任何内容。同样，这不会改变代码的工作方式，只是更整洁而已

目前来看，这段代码还可以，但可能更好。几年前我读过一篇文章，说任何超过一个屏幕的VBA程序都太长了。我一直觉得这是一条有用的规则。更小的sub/func更易于阅读、理解和使用，即使最终拥有更多sub/func。当您对VBA更加自信时，请查看是否将其拆分为几个逻辑步骤，可能所有步骤都是从另一个子系统按顺序调用的。这样可以更容易地打开和关闭功能（例如，您可能并不总是需要标题行）。最后，我添加了可选语句。这将防止代码调用尚未声明的变量。总是良好的实践

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

Sub-simplequery（）
'导入SQL查询的结果。
Dim DbName作为字符串
'获取数据库名称。
DbName=图纸（“建模结果-1/2”）.范围（“g9”）.值
'导入查询。
运行查询“”，数据库名，工作表（“数据转储”）。范围（“A1”）
端接头

---

正如你所看到的，这艘潜艇不再有很多功能了。所有的工作都已转移到

运行查询中

嗨，我明白你的意思，但不知道如何在查询中实现这一点？你能复制它并给我看吗？我会非常感激的！最好的问候，JamesTry解决方案一（总体上更容易）。如果您无法使其工作，请编辑您的问题，以显示您尝试的内容及其返回的错误消息。希望到时候我有更多的时间帮忙。嗨，对不起！没有