Excel 2003 - VBA - use ADO recordset & create pivot table - Part 2

[silentbuddha]

Hi,

many threads have been created..but i figure nothing wrong with rehashing some old stuff....

I hope it may help those new to working with VBA and pvitocache, pivottable, pivotfield etc....

Feel free to add corrections to make the code work more efficiently

***************** code *******************

Private Sub getRetentionDetails2(date1 As String, date2 As String)
'This was set up using Microsoft ActiveX Data Components version 2.8
'this procedure will use ADO to connect to sql server 2005
'it will then paste the ADO recorset onto a worksheet
'it will then use the data from the worksheet to create pivot table



Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim fld As ADODB.Field
Dim strSQL As String
Dim wb As Workbook
Dim ws As Worksheet
Dim rangeStart As Range
Dim pvtTable As PivotTable
Dim pvtField As PivotField
Dim pvtItem As PivotItem
Dim objPvtCache As PivotCache

Dim iCol As Integer
Dim i As Integer

Const CONN_STRING As String = "Provider=SQLNCLI;Server=sql.XYZreporting;Database=business_analysis;Trusted_Connection=yes;HDR=yes"";"

Set wb = ActiveWorkbook
Set ws = wb.Worksheets("RETENTION_DETAILS")

With ws

.Cells.Clear
.Cells.ClearContents
.Cells.ClearFormats

Set rangeStart = .Range("A2")

End With

strSQL = "exec PRG_Consolidated_KPI_RetentionDetails " & "'" & date1 & "'" & " , " & "'" & date2 & "'"

'Create the ADO connection object
Set conn = New ADODB.Connection

'Apply some settings to the ADO connection object
'Open the connection to the database : .Open CONN_STRING
'Store the result in rs recordset object : Set rs = .Execute(strSQL)
With conn
.CursorLocation = adUseClient
.Open CONN_STRING
.CommandTimeout = 0
Set rs = .Execute(strSQL)
End With


'Apply the rs fieldnames ( column headers ) into Worksheets("RETENTION_DETAILS")
iCol = 1
For Each fld In rs.Fields

MsgBox "column # " & iCol & " fieldname is : " & fld.Name

ws.Cells(1, iCol).Value = fld.Name
iCol = iCol + 1
Next

'Paste the dataportion of the recordset into Worksheets("RETENTION_DETAILS")
rangeStart.CopyFromRecordset rs

'Correct cell with values stored as text on the Worksheets("RETENTION_DETAILS")
With ws.UsedRange
.Value = .Value
End With


'Initiate PivotCache object to accept external data
'since the data that we are using to feed the objPvtCache is from the current activeworksheet, the SourceType must be "xlDatabase"
Set objPvtCache = ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:=ws.UsedRange)

'Assign the objPvtCache to pvtTable object and create the pivot table
Set pvtTable = objPvtCache.CreatePivotTable(TableDestination:=ws.Range("Z10"), TableName:="RETENTION_DETAILS")

With pvtTable

For Each pvtField In .PivotFields

If pvtField.Name = "Week" Then

MsgBox "the first pivot field is " & pvtField.Name
.AddFields ColumnFields:=pvtField.Name
pvtField.Orientation = xlColumnField
Else

MsgBox "the next pivot field is " & pvtField.Name
.AddDataField pvtField

End If

Next

End With

'cleanup and close connection
rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing
Set fld = Nothing
Set rangeStart = Nothing
Set objPvtCache = Nothing

End Sub