I have a macro that I use to get data from an Access database, pass it into a recordset and then drop it into a worksheet in a crosstab format. Currently all my data starts in a SQL Server, gets pulled into Access, and then my macro takes it from there.
I’m trying to cut Access out of the process. What I need is the code to point at an external data source rather than to an Access mdb, which results in me getting the same recordset for the rest of the macro to process. My whole code is below; I’ve marked the part I’m looking to change.
' 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
I initially thought that if I established the data connection and had it saved in an .odc file, that referencing that file in vba would be simple. But all I’ve been able to find is code for establishing new data connections directly in vba with a connection string. Is this what I have to do? If so is there a way to do it so that the code will work regardless of the user running it?
I'm using Excel 2010
Thanks
This is an ADO code sample you can use to connect to SQL Server: You must add a reference to 'Microsoft ActiveX Data Objects 6.1' first
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