使用现有的外部数据连接创建记录集

Question

我有一个宏，可用于从 Access 数据库获取数据，将其传递到记录集中，然后将其放入交叉表格式的工作表中。目前我的所有数据都在 SQL 服务器中启动，被拉入 Access，然后我的宏从那里获取它。
我正在尝试将 Access 排除在流程之外。我需要的是指向外部数据源而不是 Access mdb 的代码，这导致我获得相同的记录集供宏的其余部分处理。我的整个代码如下；我已经标记了我要更改的部分。

' Gets the prior incurred claims estimates data from the Access database
' "RestatedIncurredClaims.mdb" in the same folder as the model, and sets up
' the tables on the Prior_Claims sheet to contain the data.
Public Sub GetPriorClaimsData()
    If [MODEL_NAME] = "" Then
        Dim modelName As String
        modelName = Replace(ThisWorkbook.Name, "ReserveModel_", "")
        modelName = Left(modelName, InStr(modelName, ".") - 1)
        [MODEL_NAME] = modelName
    End If


   ' WANT TO CHANGE THIS PART

Dim dbPath As String
dbPath = ThisWorkbook.Path & "\RestatedIncurredClaims.mdb"

Application.Calculation = xlCalculationManual

On Error GoTo priorClaimsErr

Application.StatusBar = "Opening prior claims database..."

' Open the database
' Options:=False means non-exclusive, see:
' http://msdn.microsoft.com/en-us/library/office/ff835343.aspx
Dim db As Database
Set db = Workspaces(0).OpenDatabase(Name:=dbPath, _
    Options:=False, ReadOnly:=True)

Application.StatusBar = "Getting prior claims data..."

' Execute query to get prior incurred claim estimates for this model only
Dim rs As Recordset
Set rs = db.OpenRecordset( _
    "SELECT * FROM [Restated incurred claims] WHERE [model_name] = """ _
        & [MODEL_NAME] & """")

' WANT TO LEAVE EVERYTHING ELSE THE SAME


Dim i As Long, numCellsFound As Long
Dim iLOB As Long, iTOS As Long, iReported As Long, iIncurred As Long
numCellsFound = 0

' Create the array that will hold the prior claims data during processing
Dim priorClaimsData() As Variant
ReDim priorClaimsData( _
    0 To [PRIOR_CLAIMS_TABLES].Rows.Count - 1, _
    0 To [PRIOR_CLAIMS_TABLES].Columns.Count - 1)

If rs.RecordCount > 0 Then

    Application.StatusBar = "Clearing prior claims data..."
    [PRIOR_CLAIMS_TABLES].ClearContents

    Dim lookupLOB As New Dictionary
    For i = 1 To [LST_LINES].Cells.Count
        lookupLOB([LST_LINES].Cells(i).Value) = i
    Next

    Dim lookupTOS As New Dictionary
    For i = 1 To [LST_TYPES_SHORT].Cells.Count
        lookupTOS([LST_TYPES_SHORT].Cells(i).Value) = i
    Next

    Dim lookupDate As New Dictionary
    For i = 1 To [PRIOR_CLAIMS_DATES].Cells.Count
        lookupDate([PRIOR_CLAIMS_DATES].Cells(i).Value) = i
    Next

    rs.MoveFirst
    Do Until rs.EOF
        If rs.AbsolutePosition Mod 1000 = 0 Then
            Application.StatusBar = "Processing prior claims data, row " _
                & Format(rs.AbsolutePosition, "#,0") & "..."
        End If

        iLOB = lookupLOB(CStr(rs!model_lob))
        iTOS = lookupTOS(CStr(rs!fnc_ben_typ_cd))
        iReported = lookupDate(CStr(rs!acct_perd_yr_mo))
        iIncurred = lookupDate(CStr(rs!clm_incr_yr_mo))

        If iLOB <> 0 And iTOS <> 0 _
            And iReported <> 0 And iIncurred <> 0 Then

            iLOB = iLOB - 1
            iTOS = iTOS - 1
            iReported = iReported - 1
            iIncurred = iIncurred - 1
            priorClaimsData( _
                iLOB * ROWS_PER_LOB + iIncurred, _
                iTOS * COLS_PER_TOS + iReported) = rs!rst_incur_clm
            numCellsFound = numCellsFound + 1
        End If

        rs.MoveNext
    Loop

    [PRIOR_CLAIMS_TABLES].Value = priorClaimsData

End If

If numCellsFound = 0 Then
    MsgBox Prompt:="No prior estimates data found for this model (" _
            & [MODEL_NAME] & ").", _
        Title:="Warning", _
        Buttons:=vbExclamation + vbOKOnly
End If

GoTo closeDb

priorClaimsErr:
    MsgBox Prompt:="Failed to update the prior claim estimates data:" _
        & vbCrLf & vbCrLf & Err.Description, _
    Title:="Warning", _
    Buttons:=vbExclamation + vbOKOnly

closeDb:
    Application.StatusBar = "Closing prior claims database..."

If Not rs Is Nothing Then
    rs.Close
    Set rs = Nothing
End If

If Not db Is Nothing Then
    db.Close
    Set db = Nothing
End If

Application.StatusBar = "Recalculating..."

Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False
End Sub

我最初认为，如果我建立数据连接并将其保存在 .odc 文件中，那么在 vba 中引用该文件会很简单。但我所能找到的只是直接在 vba 中使用连接字符串建立新数据连接的代码。这是我必须做的吗？如果是这样，有没有办法让代码无论用户如何都可以工作运行？

我正在使用 Excel 2010

谢谢

Answer 1

这是一个 ADO 代码示例，您可以使用它来连接到 SQL 服务器：您必须先添加对 'Microsoft ActiveX Data Objects 6.1' 的引用

SQLSERVER_CONN_STRING = "Provider=SQLOLEDB.1;Data Source=<server name or IP address>;User ID=<User_id>;Password=<pwd>;Initial Catalog=<initial cat>;"


Dim oConn As ADODB.Connection
Dim rs as ADODB.Recorset
Dim sSQL as String

Set oConn = New ADODB.Connection
oConn.CommandTimeout = 60
oConn.ConnectionTimeout = 30

oConn.Open SQLSERVER_CONN_STRING

Set rs = New ADODB.Recordset
'note that SQL Server query syntax is different!
sSql = "SELECT * FROM [Restated incurred claims] WHERE [model_name] = '" & [MODEL_NAME] & "'")

rs.Open sSQL, oConn, adOpenStatic, adLockOptimistic, adCmdText
If Not rs Is Nothing Then
  If rs.State = 1 Then
    If rs.RecordCount > 0 Then

       <your code here>

    end if
  End If
End If

If Not rs Is Nothing Then 
    If rs.State = 1 Then rs.Close
End if

If Not oConn Is Nothing Then 
    If oConn.State = 1 Then oConn.Close
End if

使用现有的外部数据连接创建记录集

Using an existing external data connection to create a recordset

excel

vba

recordset

excel-external-data