使用現有的外部數據連接創建記錄集

Question

我有一個宏，用於從Access數據庫中獲取數據，將其傳遞到記錄集，然后以交叉表格式將其放入工作表中。 目前，我所有的數據都始於SQL Server，並被拉入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 Server：必須首先添加對“ Microsoft ActiveX數據對象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