Public Sub NetworkCrossCheck()
Dim rsReport As New ADODB.Recordset
Dim cnReport As New ADODB.Connection
Dim cmdReport As New ADODB.Command
Dim lrow As Long
Dim lCol As Long
Dim pc As PivotCache
Dim pt As PivotTable
Dim wb As Workbook

On Error GoTo NetworkCrossCheckError

cnReport.ConnectionString = "DSN=CM_Mod3SQL_DEV;"
cnReport.CursorLocation = adUseClient
cnReport.Open

If (cnReport.State < adStateOpen) Then
MsgBox "Database connection not open, cannot run
query"
Exit Sub
End If

Set cmdReport.ActiveConnection = cnReport
cmdReport.CommandText = "rpt_NetworkCrossCheck_sp"
cmdReport.CommandType = adCmdStoredProc
cmdReport.CommandTimeout = 300

Set rsReport = cmdReport.Execute

Set wb = Workbooks.Open(sPath
& "NetworkCrossCheck_template.xls", 0, True)
Set pc = ActiveWorkbook.PivotCaches.Add
(SourceType:=xlExternal)
Set pc.Recordset = rsReport
pc.CreatePivotTable TableDestination:=Range("A3"),
TableName:="Network Cross Check"


With ActiveSheet.PivotTables("Network Cross Check")
.SmallGrid = False
.RowGrand = False
.ColumnGrand = False
With .PivotFields("NetworkName")
.Orientation = xlRowField
.Position = 1
End With
With .PivotFields("NetworkName1")
.Orientation = xlColumnField
.Position = 1
End With
With .PivotFields("TaxID")
.Orientation = xlDataField
.Position = 1

End With
End With

Set rsReport = Nothing
Set cmdReport = Nothing
Set cnReport = Nothing
Set wb = Nothing
'cnReport.Close

Exit Sub

NetworkCrossCheckError:
MsgBox CStr(Err.Number) & ": " & Err.Description &
vbCrLf & "Please call support",
vbExclamation, "NetworkCrossCheck"
Resume Next

End Sub