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

这是一个可用于连接SQL Server的ADO代码示例：您必须添加对Microsoft ActiveX Data Objects 6.1＆＃39; Microsoft ActiveX Data Objects 6.1＆＃39;第一

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

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

1 个答案: