Kod:
Function fProcErrs()
On Error GoTo Proc_Err
Dim booLeaveOpen As Boolean
Dim wbkNew As Workbook
Dim wksData As Worksheet
Dim dbLocal As Database
Dim snpErrors As DAO.Recordset
Dim intCurrTask As Integer
Dim rngCurr As Excel.Range
Dim wksPivot As Worksheet
Dim Cache As Excel.PivotCache
Dim pTable As Excel.PivotTable
Dim strSQL As String
'if Excel is already open, use that instance
booLeaveOpen = True
'attempting to use something that is not available will
'generate an error
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
On Error GoTo Proc_Err
'if xlApp is defined then we already have a conversation
If TypeName(xlApp) = "Nothing" Then
booLeaveOpen = False
'Excel was not open - create new instance
Set xlApp = CreateObject("Excel.Application")
End If
xlApp.Visible = True
Set wbkNew = xlApp.Workbooks.Add
Set wksData = wbkNew.ActiveSheet
Set wksPivot = wbkNew.Sheets(2)
wksPivot.Name = "Pivot"
wksData.Name = "ProcErrors"
Set dbLocal = CurrentDb()
strSQL = "SELECT tbl_AuditTypes.AuditType, tbl_AuditData.AudDate, " & _
"tbl_AuditData.ClaimNumber, tbl_PQuestData.QNotes, tbl_PQuestData.Qnum, " & _
"tbl_Questions.Question, [BSFirstName] & ' ' & [BSLastName] AS Assignee, " & _
"[AudFirstName] & ' ' & [AudLastName] AS Auditor, [MgrFirstName] & ' ' & [MgrLastName] AS Manager, " & _
"tbl_Office.Office, [SupFirstName] & ' ' & [SupLastName] AS Supervisor, tbl_Training.Training " & _
"FROM tbl_Auditors INNER JOIN (tbl_Office INNER JOIN (((tbl_ManagerID " & _
"INNER JOIN tbl_Supervisor ON tbl_ManagerID.MgrID = tbl_Supervisor.MgrID) " & _
"INNER JOIN tbl_Assignee ON tbl_Supervisor.SupID = tbl_Assignee.SupID) " & _
"INNER JOIN ((tbl_AuditTypes INNER JOIN (tbl_AuditData INNER JOIN tbl_Training " & _
"ON tbl_AuditData.TrnID = tbl_Training.TrnID) ON tbl_AuditTypes.AudTyID = " & _
"tbl_AuditData.AudTyID) INNER JOIN (tbl_Questions INNER JOIN tbl_PQuestData " & _
"ON tbl_Questions.QID = tbl_PQuestData.QID) ON tbl_AuditData.AuditID = " & _
"tbl_PQuestData.AuditID) ON tbl_Assignee.AssignID = tbl_AuditData.AssignID) " & _
"ON tbl_Office.OfficeID = tbl_Assignee.OfficeID) ON tbl_Auditors.AuditorID = " & _
"tbl_AuditData.AuditorID " & _
"WHERE (((tbl_AuditData.AudDate) Between #" & [Forms]![frm_ErrorRpts]![StartDate] & "# And" & _
" #" & [Forms]![frm_ErrorRpts]![EndDate] & "#) " & _
" AND((tbl_PQuestData.Response)=0));"
'Debug.Print strSQL
Set snpErrors = dbLocal.OpenRecordset(strSQL, dbOpenSnapshot)
snpErrors.MoveLast
snpErrors.MoveFirst
Set rngCurr = wksData.Range(wksData.Cells(2, 1), _
wksData.Cells(2 + snpErrors.RecordCount, 1))
'populates new worksheet with data from qry_Errors
rngCurr.CopyFromRecordset snpErrors
Resume430:
'adds column headings and some formatting
With wksData
.Cells(1, 1).Value = "Audit Type"
.Cells(1, 1).Font.Bold = True
.Cells(1, 2).Value = "Audit Date"
.Cells(1, 2).Font.Bold = True
.Cells(1, 3).Value = "Claim Number"
.Cells(1, 3).Font.Bold = True
.Cells(1, 4).Value = "Comments"
.Cells(1, 4).Font.Bold = True
.Cells(1, 5).Value = "Question Number"
.Cells(1, 5).Font.Bold = True
.Cells(1, 6).Value = "Question"
.Cells(1, 6).Font.Bold = True
.Cells(1, 7).Value = "Assignee"
.Cells(1, 7).Font.Bold = True
.Cells(1, 8).Value = "Auditor"
.Cells(1, 8).Font.Bold = True
.Cells(1, 9).Value = "Manager"
.Cells(1, 9).Font.Bold = True
.Cells(1, 10).Value = "Office"
.Cells(1, 10).Font.Bold = True
.Cells(1, 11).Value = "Supervisor"
.Cells(1, 11).Font.Bold = True
.Cells(1, 12).Value = "Training"
.Cells(1, 12).Font.Bold = True
.Columns("A:L").AutoFit
.Columns("A:L").WrapText = True
.Columns("D").ColumnWidth = 50
.Columns("F").ColumnWidth = 50
End With
Set Cache = xlApp.ActiveWorkbook.PivotCaches.Add( _
xlDatabase, wksData.Name & "!R1C1:R" & snpErrors.RecordCount + 1 & "C12")
Set pTable = Cache.CreatePivotTable(wksPivot.Cells(4, 1), "PivotTable1")
wksPivot.Select
Set wksPivot = wbkNew.ActiveSheet
xlApp.ActiveSheet.PivotTables("PivotTable1").SmallGrid = False
'format pivot table
With xlApp.ActiveSheet.PivotTables("PivotTable1").PivotFields("Audit Type")
.Orientation = xlPageField
.Position = 1
End With
With xlApp.ActiveSheet.PivotTables("PivotTable1").PivotFields("Question")
.Orientation = xlRowField
.Position = 1
End With
With xlApp.ActiveSheet.PivotTables("PivotTable1").PivotFields("Claim Number")
.Orientation = xlDataField
.Position = 1
End With
With xlApp.ActiveSheet.PivotTables("PivotTable1").PivotFields("Claim Number")
.Orientation = xlDataField
.Position = 2
End With
With xlApp.ActiveSheet.PivotTables("PivotTable1").PivotFields("Data")
.Orientation = xlColumnField
.Position = 1
End With
With xlApp.ActiveSheet.PivotTables("PivotTable1").PivotFields( _
"Count of Claim Number2")
.Calculation = xlPercentOfColumn
.NumberFormat = "0%"
End With
With wksPivot
.Columns("A").ColumnWidth = 50
End With
xlApp.ActiveSheet.PivotTables("PivotTable1").PivotFields("Audit Type").CurrentPage = _
"Dental BS Audit"
Proc_Exit:
On Error Resume Next
If TypeName(xlApp) <> "Nothing" Then
'xlApp.ActiveWorkbook.Close True
'If Not booLeaveOpen Then xlApp.Quit
Set xlApp = Nothing
End If
Exit Function