E
EAB1977
All,
Can anyone tell me why Excel hangs? I THINK I'm doing everything
right, but Excel continues to hang and I can't figure out why (Access
code to Excel code).
Eric
Sub GetTechnicianReport(datStart As Date, datEnd As Date)
Dim db As DAO.Database, rst As DAO.Recordset, rst2 As DAO.Recordset,
xl As Object, qdfTechReport As DAO.QueryDef
Dim intCol As Integer, intRow As Integer, fld As Variant, strLetter
As
String, x As Integer, i As Integer
Dim vbCom As Object 'http://www.ozgrid.com/VBA/delete-module.htm
Dim y As Integer, strPath As String, rst3 As DAO.Recordset, strRank
As
String
Dim LastRow As Long, LastCol As Long, RngToSort As Object, qdfReports
As QueryDef
On Error GoTo GetTechnicianReport_Err
'Reload production info to get the most up-to-date data
DoCmd.OpenForm "frmProcessing", acNormal
DoEvents
Set db = CurrentDb
DoCmd.SetWarnings False
DoCmd.RunSQL "DELETE * from tmpReports"
Set qdfReports = db.QueryDefs("qryReports2")
qdfReports.Execute
DoCmd.SetWarnings True
Set qdfReports = Nothing
'Update tmpReports table to the names in the tblEmployee table
DoCmd.SetWarnings False
DoCmd.RunSQL "UPDATE tmpReports SET tmpReports.UserName =" _
& " 'Susan Skidmore' WHERE (((tmpReports.UserName)='Sue
Skidmore'));"
DoCmd.RunSQL "UPDATE tmpReports SET tmpReports.UserName =" _
& " 'Kimberly Van Valkenburgh' WHERE
(((tmpReports.UserName)='Kim Van Valkenburgh'));"
DoCmd.SetWarnings True
DoCmd.Close acForm, "frmProcessing"
DoEvents
'Generate query & report
Set xl = CreateObject("Excel.Application")
With xl
.Visible = False
.Workbooks.Open "\\files-2k1\ENG\QA\Database\Productivity
\TechReport.xlt"
.Interactive = False
.DisplayAlerts = False
.ScreenUpdating = False
.Sheets("Sheet1").Select
'Generate query
Set qdfTechReport = db.QueryDefs("qryTechReport")
qdfTechReport.SQL = "SELECT tblEmployee.EmpRptID,
TEMP.ProductLineCode, tblEmployee.UserName," _
& " Sum(TEMP.NumOfSets) AS SumOfNumOfSets FROM tblEmployee
LEFT JOIN (SELECT UserName," _
& " ProductLineCode, NumOfSets FROM tmpReports WHERE
tmpReports.CompleteDate Between #" _
& datStart & "# And #" & datEnd & "#) As TEMP ON
tblEmployee.UserName = TEMP.UserName WHERE" _
& " tblEmployee.IsCQATech = True AND tblEmployee.EmpRptID IS
NOT NULL GROUP BY tblEmployee.EmpRptID," _
& " TEMP.ProductLineCode, tblEmployee.UserName;"
Set qdfTechReport = Nothing
.Range("A1").Value = "Completed Production Dates: " &
datStart
& " and " & datEnd
'Generate Report
.Range("A3").Select
.Worksheets("Sheet1").Columns("A").ColumnWidth = 15.71
.Worksheets("Sheet1").Columns("C").ColumnWidth = 8.43
Set rst = db.OpenRecordset("qryTechReport_Crosstab")
For Each fld In rst.Fields
.ActiveCell.Value = fld.Name
With .ActiveCell.Borders(9)
.LineStyle = 1
.ColorIndex = 0
.Weight = 2
End With
With .ActiveCell.Interior
.ColorIndex = 15
.Pattern = 1
.PatternColorIndex = -4105
End With
.ActiveCell.Offset(0, 1).Select
Next fld
strLetter = GetColumnLetter(.ActiveCell.Column - 1)
.ActiveCell.Offset(1, -(.ActiveCell.Column - 1)).Select
rst.MoveFirst
Do Until rst.EOF
For x = 0 To rst.Fields.Count - 1
.ActiveCell.Offset(0, x).Value = rst.Fields(x).Value
Next x
rst.MoveNext
.ActiveCell.Offset(1, 0).Select
Loop
'Create the ranks sheet table
.Worksheets("Sheet1").Columns("A").Select
.CutCopyMode = 1
.Selection.Copy
.Worksheets("Sheet2").Select
.Range("A1").PasteSpecial -4104
.ActiveCell.Offset(0, 1).Select
'Order the sheet by where the techs rank
Set qdfTechReport = db.QueryDefs("qryRank")
qdfTechReport.SQL = "SELECT tblEmployee.EmpRptID,
tblEmployee.UserName, Sum(TEMP.NumOfSets) AS" _
& " SumOfNumOfSets FROM tblEmployee LEFT JOIN (SELECT
UserName, NumOfSets FROM tmpReports WHERE" _
& " tmpReports.CompleteDate Between #" & datStart & "# And #"
& datEnd & "#) AS TEMP ON" _
& " tblEmployee.UserName = TEMP.UserName WHERE
tblEmployee.IsCQATech = True And tblEmployee.EmpRptID" _
& " Is Not Null GROUP BY tblEmployee.EmpRptID,
tblEmployee.UserName ORDER BY Sum(TEMP.NumOfSets) DESC;"
Set qdfTechReport = Nothing
Set rst3 = db.OpenRecordset("SELECT EmpRptID FROM qryRank")
.Sheets("Sheet1").Select
rst3.MoveFirst
.Range("B3").Select
Do Until rst3.EOF
If .ActiveCell.Value = rst3!EmpRptID Then
.Worksheets("Sheet1").Columns(GetColumnLetter(.ActiveCell.Column)).Select
.CutCopyMode = 1
.Selection.Copy
.Worksheets("Sheet2").Select
.ActiveCell.PasteSpecial -4104
.ActiveCell.Offset(0, 1).Select
.Worksheets("Sheet1").Select
.Range("B3").Select
rst3.MoveNext
Else
.ActiveCell.Offset(0, 1).Select
End If
Loop
'Delete the first sheet
.Sheets("Sheet1").Delete
.Sheets("Sheet2").Select
'Create the Average Line value
.Range("A4").Select
If .ActiveCell.Value = "" Then .Rows(.ActiveCell.Row).Delete
Do Until .ActiveCell.Value = ""
.ActiveCell.Offset(1, 0).Select
Loop
intRow = .ActiveCell.Row
.Range("B" & intRow).Select
.ActiveCell.Value = "=Round(Sum(B4:S" & intRow - 1 & ")/
18,0)"
.ActiveCell.Value = .ActiveCell.Value2 'Make the formula
become a static number
.ActiveCell.AutoFill Destination:=.Range("B" & intRow & ":" &
strLetter & intRow), Type:=0
'Chart Creation
intRow = intRow - 1
.ActiveWorkbook.Charts.Add
After:=.Worksheets(.Worksheets.Count)
.ActiveChart.SetSourceData Source:=.Range("'Sheet2'!$A$3:$" &
strLetter & "$" & intRow)
.ActiveChart.ChartType = 52
.ActiveChart.HasTitle = True
.ActiveChart.ChartTitle.Text = "Individual Parts Chart" &
Chr(13) _
& "Completed Production Dates: " & datStart & " and " &
datEnd
.ActiveChart.SeriesCollection(1).Select
'Set the charts bar color
With .ActiveChart
For i = .SeriesCollection.Count To 1 Step -1
With .SeriesCollection(i)
Select Case .Name
Case "0EPS"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 1
.Pattern = 1
End With
Case "0LID"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 39
.Pattern = 1
End With
Case "0OPS"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 19
.Pattern = 1
End With
Case "DELI"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 35
.Pattern = 1
End With
Case "PEPS"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 8
.Pattern = 1
End With
.Interior.ColorIndex = 8
Case "0PPC"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 7
.Pattern = 1
End With
Case "CCUP"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 41
.Pattern = 1
End With
Case "0PET"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 4
.Pattern = 1
End With
Case "IDIN"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 27
.Pattern = 1
End With
Case "EXTF"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 3
.Pattern = 1
End With
Case "HAVI"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 43
.Pattern = 1
End With
Case "FILM"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 53
.Pattern = 1
End With
Case "Gloss"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 10
.Pattern = 1
End With
End Select
End With
Next i
End With
'Create the Average line in the chart
.ActiveChart.PlotArea.Select
.ActiveChart.SeriesCollection.NewSeries
y = .ActiveChart.SeriesCollection.Count
.ActiveChart.SeriesCollection(y).Values = "=Sheet2!R" &
intRow
+ 1 & "C2:R" & intRow + 1 & "C" & rst.Fields.Count
.ActiveChart.SeriesCollection(y).Name = "=""Average"""
.ActiveChart.SeriesCollection(y).Select
.ActiveChart.SeriesCollection(y).AxisGroup = 1
.ActiveChart.SeriesCollection(y).ChartType = 4
.ActiveChart.SeriesCollection(y).Border.ColorIndex = 1
If .ActiveChart.SeriesCollection.Count
= .ActiveChart.Legend.LegendEntries.Count Then
.ActiveChart.Legend.LegendEntries(y).Select
.Selection.Delete
End If
.ActiveChart.PlotArea.Select
.ActiveChart.Axes(1).Select
.ActiveChart.SeriesCollection(1).Select
.ActiveChart.SeriesCollection(1).XValues
= .Worksheets("Sheet2").Range("B3:S3")
'Generate Weight Factor Report
.Sheets("Sheet3").Select
.Range("A3").Select
.Worksheets("Sheet3").Columns("A").ColumnWidth = 15.71
.Worksheets("Sheet3").Columns("C").ColumnWidth = 8.43
Set rst = db.OpenRecordset("qryTechReport_Crosstab")
For Each fld In rst.Fields
.ActiveCell.Value = fld.Name
With .ActiveCell.Borders(9)
.LineStyle = 1
.ColorIndex = 0
.Weight = 2
End With
With .ActiveCell.Interior
.ColorIndex = 15
.Pattern = 1
.PatternColorIndex = -4105
End With
.ActiveCell.Offset(0, 1).Select
Next fld
strLetter = GetColumnLetter(.ActiveCell.Column - 1)
.ActiveCell.Offset(1, -(.ActiveCell.Column - 1)).Select
rst.MoveFirst
Do Until rst.EOF
For x = 0 To rst.Fields.Count - 1
.ActiveCell.Offset(0, x).Value = rst.Fields(x).Value
If x > 0 Then
If Not IsNull(rst.Fields(0).Value) Then
Set rst2 = db.OpenRecordset("SELECT WgtFtr
FROM tblWgtFtr WHERE" _
& " ProdLine = '" & rst.Fields(0).Value &
"'")
If .ActiveCell.Offset(0, x).Value * rst2!
WgtFtr <> 0 Then
.ActiveCell.Offset(0, x).Value2 =
"=Round(" & .ActiveCell.Offset(0, x).Value * rst2!WgtFtr & ",0)"
End If
Set rst2 = Nothing
End If
End If
Next x
rst.MoveNext
.ActiveCell.Offset(1, 0).Select
Loop
.Range("A4").Select
If .ActiveCell.Value = "" Then .Rows(.ActiveCell.Row).Delete
Do Until .ActiveCell.Value = ""
.ActiveCell.Offset(1, 0).Select
Loop
intRow = .ActiveCell.Row
.Range("B" & intRow).Select
.ActiveCell.Value = "=Sum(B4:B" & intRow - 1 & ")"
.ActiveCell.AutoFill Destination:=.Range("B" & intRow & ":" &
strLetter & intRow), Type:=0
.ActiveCell.Offset(1, 0).Select
.ActiveCell.Value = "=Round(Sum(B4:" & strLetter & intRow - 1
& ")/18,0)"
.ActiveCell.Value = .ActiveCell.Value2 'Make the formula
become a static number
.ActiveCell.AutoFill Destination:=.Range("B" & intRow + 1 &
":" & strLetter & intRow + 1), Type:=0
.Range("A4").Select
x = 0
Do Until .ActiveCell.Value = ""
.ActiveCell.Offset(1, 0).Select
x = x + 1
Loop
intRow = .ActiveCell.Row - 1
'Create the rank table
.Sheets.Add After:=.Sheets(.Sheets.Count)
.Sheets("Sheet1").Name = "Sheet4"
.Sheets("Sheet3").Select
.Range("B3").Select
Do Until .ActiveCell.Value = ""
.CutCopyMode = 1
.ActiveCell.Copy
.Sheets("Sheet4").Select
.Range("A1").Select
Do
If .ActiveCell.Value = "" Then
Exit Do
Else
.ActiveCell.Offset(1, 0).Select
End If
Loop
.ActiveCell.PasteSpecial -4163
.ActiveCell.Offset(0, 1).Select
.Sheets("Sheet3").Select
.ActiveCell.Offset(x + 1, 0).Copy
.Sheets("Sheet4").Select
.ActiveCell.PasteSpecial -4163
.ActiveCell.Offset(1, -1).Select
.Sheets("Sheet3").Select
.ActiveCell.Offset(0, 1).Select
Loop
With .Worksheets("Sheet4")
LastRow = .Cells(.Rows.Count, "A").End(-4162).Row
LastCol = .Cells(1, .Columns.Count).End(-4159).Column
Set RngToSort = .Range("A1", .Cells(LastRow, LastCol))
End With
With RngToSort
.Cells.Sort _
Key1:=.Columns(2), Order1:=2, _
header:=2, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=1
End With
'Order the Crosstab table
.Sheets.Add After:=.Sheets(.Sheets.Count)
.Sheets(.Sheets.Count).Name = "Sheet5"
.Sheets("Sheet3").Select
.Range("A1").Select
.CutCopyMode = 1
.ActiveCell.EntireColumn.Select
.ActiveCell.EntireColumn.Copy
.Sheets("Sheet5").Select
.ActiveCell.Range("A1").Select
.ActiveCell.PasteSpecial -4104
.ActiveCell.Offset(0, 1).Select
.Sheets("Sheet4").Select
intRow = .ActiveCell.Row - 1
.Range("A1").Select
strRank = .ActiveCell.Value
.Sheets("Sheet3").Select
.Range("B3").Select
Do
If .ActiveCell.Value = strRank Then
.CutCopyMode = 1
.ActiveCell.EntireColumn.Select
.ActiveCell.EntireColumn.Copy
.Sheets("Sheet5").Select
.ActiveCell.PasteSpecial -4104
.ActiveCell.Offset(0, 1).Select
.Sheets("Sheet4").Select
.ActiveCell.Offset(1, 0).Select
strRank = .ActiveCell.Value
If strRank = "" Then Exit Do
.Sheets("Sheet3").Select
.Range("B3").Select
Else
.ActiveCell.Offset(0, 1).Select
End If
Loop
'Generating Chart
.Sheets("Sheet5").Select
.Range("A4").Select
Do
If .ActiveCell.Value = "" Then
intRow = .ActiveCell.Row - 1
Exit Do
Else
.ActiveCell.Offset(1, 0).Select
End If
Loop
.Range("A3").Select
Do
If .ActiveCell.Value = "" Then
strLetter = GetColumnLetter(.ActiveCell.Column - 1)
Exit Do
Else
.ActiveCell.Offset(0, 1).Select
End If
Loop
.ActiveWorkbook.Charts.Add
After:=.Worksheets(.Worksheets.Count)
.ActiveChart.SetSourceData Source:=.Range("'Sheet5'!$A$3:$" &
strLetter & "$" & intRow)
.ActiveChart.ChartType = 52
.ActiveChart.HasTitle = True
.ActiveChart.ChartTitle.Text = "Weight Factor Chart" &
Chr(13)
_
& "Completed Production Dates: " & datStart & " and " &
datEnd
.ActiveChart.Legend.LegendEntries(.ActiveChart.SeriesCollection.Count).Sele
ct
'.Selection.Delete
'.ActiveChart.SeriesCollection(1).Select
'.Selection.Delete
'Set the charts bar color
With .ActiveChart
For i = .SeriesCollection.Count To 1 Step -1
With .SeriesCollection(i)
Select Case .Name
Case "0EPS"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 1
.Pattern = 1
End With
Case "0LID"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 39
.Pattern = 1
End With
Case "0OPS"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 19
.Pattern = 1
End With
Case "DELI"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 35
.Pattern = 1
End With
Case "PEPS"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 8
.Pattern = 1
End With
.Interior.ColorIndex = 8
Case "0PPC"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 7
.Pattern = 1
End With
Case "CCUP"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 41
.Pattern = 1
End With
Case "0PET"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 4
.Pattern = 1
End With
Case "IDIN"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 27
.Pattern = 1
End With
Case "EXTF"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 3
.Pattern = 1
End With
Case "HAVI"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 43
.Pattern = 1
End With
Case "FILM"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 53
.Pattern = 1
End With
Case "Gloss"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 10
.Pattern = 1
End With
End Select
End With
Next i
End With
'Create the Average line in the chart
.ActiveChart.PlotArea.Select
.ActiveChart.SeriesCollection.NewSeries
y = .ActiveChart.SeriesCollection.Count
.ActiveChart.SeriesCollection(y).Values = "=Sheet5!R" &
intRow
+ 2 & "C2:R" & intRow + 2 & "C" & rst.Fields.Count
.ActiveChart.SeriesCollection(y).Name = "=""Average"""
.ActiveChart.SeriesCollection(y).Select
.ActiveChart.SeriesCollection(y).AxisGroup = 1
.ActiveChart.SeriesCollection(y).ChartType = 4
.ActiveChart.SeriesCollection(y).Border.ColorIndex = 1
If .ActiveChart.SeriesCollection.Count
= .ActiveChart.Legend.LegendEntries.Count Then
.ActiveChart.Legend.LegendEntries(y).Select
.Selection.Delete
End If
.ActiveChart.PlotArea.Select
.ActiveChart.Axes(1).Select
.ActiveChart.SeriesCollection(1).XValues
= .Worksheets("Sheet4").Range("A1:A18")
'Unlink the chart from the data & remove Module1 from the
Excel VBE.
'http://www.ozgrid.com/VBA/delete-module.htm
.Charts("Chart1").Select
.Run ("DelinkChartFromData")
.Charts("Chart2").Select
.Run ("DelinkChartFromData")
Set vbCom = .VBE.ActiveVBProject.VBComponents
vbCom.Remove VBComponent:=vbCom.Item("Module1")
Set vbCom = Nothing
'Save the Excel sheet
.Charts("Chart1").Select
strPath = "G:\" & Month(Date) & "_" & Day(Date) & "_" &
Year(Date) & ".xls"
If .Version = "12.0" Then
.ActiveWorkbook.SaveAs strPath
Else
.ActiveWorkbook.SaveAs strPath, 43
End If
End With
Call TechWeightFactor(strPath)
xl.Visible = True
xl.DisplayAlerts = True
xl.ScreenUpdating = True
xl.Interactive = True
Set xl = Nothing
Set rst = Nothing
Set rst2 = Nothing
Set rst3 = Nothing
Set db = Nothing
GetTechnicianReport_Err_Exit:
Exit Sub
GetTechnicianReport_Err:
MsgBox Err.Number & " - " & Err.Description
Resume GetTechnicianReport_Err_Exit
End Sub
Can anyone tell me why Excel hangs? I THINK I'm doing everything
right, but Excel continues to hang and I can't figure out why (Access
code to Excel code).
Eric
Sub GetTechnicianReport(datStart As Date, datEnd As Date)
Dim db As DAO.Database, rst As DAO.Recordset, rst2 As DAO.Recordset,
xl As Object, qdfTechReport As DAO.QueryDef
Dim intCol As Integer, intRow As Integer, fld As Variant, strLetter
As
String, x As Integer, i As Integer
Dim vbCom As Object 'http://www.ozgrid.com/VBA/delete-module.htm
Dim y As Integer, strPath As String, rst3 As DAO.Recordset, strRank
As
String
Dim LastRow As Long, LastCol As Long, RngToSort As Object, qdfReports
As QueryDef
On Error GoTo GetTechnicianReport_Err
'Reload production info to get the most up-to-date data
DoCmd.OpenForm "frmProcessing", acNormal
DoEvents
Set db = CurrentDb
DoCmd.SetWarnings False
DoCmd.RunSQL "DELETE * from tmpReports"
Set qdfReports = db.QueryDefs("qryReports2")
qdfReports.Execute
DoCmd.SetWarnings True
Set qdfReports = Nothing
'Update tmpReports table to the names in the tblEmployee table
DoCmd.SetWarnings False
DoCmd.RunSQL "UPDATE tmpReports SET tmpReports.UserName =" _
& " 'Susan Skidmore' WHERE (((tmpReports.UserName)='Sue
Skidmore'));"
DoCmd.RunSQL "UPDATE tmpReports SET tmpReports.UserName =" _
& " 'Kimberly Van Valkenburgh' WHERE
(((tmpReports.UserName)='Kim Van Valkenburgh'));"
DoCmd.SetWarnings True
DoCmd.Close acForm, "frmProcessing"
DoEvents
'Generate query & report
Set xl = CreateObject("Excel.Application")
With xl
.Visible = False
.Workbooks.Open "\\files-2k1\ENG\QA\Database\Productivity
\TechReport.xlt"
.Interactive = False
.DisplayAlerts = False
.ScreenUpdating = False
.Sheets("Sheet1").Select
'Generate query
Set qdfTechReport = db.QueryDefs("qryTechReport")
qdfTechReport.SQL = "SELECT tblEmployee.EmpRptID,
TEMP.ProductLineCode, tblEmployee.UserName," _
& " Sum(TEMP.NumOfSets) AS SumOfNumOfSets FROM tblEmployee
LEFT JOIN (SELECT UserName," _
& " ProductLineCode, NumOfSets FROM tmpReports WHERE
tmpReports.CompleteDate Between #" _
& datStart & "# And #" & datEnd & "#) As TEMP ON
tblEmployee.UserName = TEMP.UserName WHERE" _
& " tblEmployee.IsCQATech = True AND tblEmployee.EmpRptID IS
NOT NULL GROUP BY tblEmployee.EmpRptID," _
& " TEMP.ProductLineCode, tblEmployee.UserName;"
Set qdfTechReport = Nothing
.Range("A1").Value = "Completed Production Dates: " &
datStart
& " and " & datEnd
'Generate Report
.Range("A3").Select
.Worksheets("Sheet1").Columns("A").ColumnWidth = 15.71
.Worksheets("Sheet1").Columns("C").ColumnWidth = 8.43
Set rst = db.OpenRecordset("qryTechReport_Crosstab")
For Each fld In rst.Fields
.ActiveCell.Value = fld.Name
With .ActiveCell.Borders(9)
.LineStyle = 1
.ColorIndex = 0
.Weight = 2
End With
With .ActiveCell.Interior
.ColorIndex = 15
.Pattern = 1
.PatternColorIndex = -4105
End With
.ActiveCell.Offset(0, 1).Select
Next fld
strLetter = GetColumnLetter(.ActiveCell.Column - 1)
.ActiveCell.Offset(1, -(.ActiveCell.Column - 1)).Select
rst.MoveFirst
Do Until rst.EOF
For x = 0 To rst.Fields.Count - 1
.ActiveCell.Offset(0, x).Value = rst.Fields(x).Value
Next x
rst.MoveNext
.ActiveCell.Offset(1, 0).Select
Loop
'Create the ranks sheet table
.Worksheets("Sheet1").Columns("A").Select
.CutCopyMode = 1
.Selection.Copy
.Worksheets("Sheet2").Select
.Range("A1").PasteSpecial -4104
.ActiveCell.Offset(0, 1).Select
'Order the sheet by where the techs rank
Set qdfTechReport = db.QueryDefs("qryRank")
qdfTechReport.SQL = "SELECT tblEmployee.EmpRptID,
tblEmployee.UserName, Sum(TEMP.NumOfSets) AS" _
& " SumOfNumOfSets FROM tblEmployee LEFT JOIN (SELECT
UserName, NumOfSets FROM tmpReports WHERE" _
& " tmpReports.CompleteDate Between #" & datStart & "# And #"
& datEnd & "#) AS TEMP ON" _
& " tblEmployee.UserName = TEMP.UserName WHERE
tblEmployee.IsCQATech = True And tblEmployee.EmpRptID" _
& " Is Not Null GROUP BY tblEmployee.EmpRptID,
tblEmployee.UserName ORDER BY Sum(TEMP.NumOfSets) DESC;"
Set qdfTechReport = Nothing
Set rst3 = db.OpenRecordset("SELECT EmpRptID FROM qryRank")
.Sheets("Sheet1").Select
rst3.MoveFirst
.Range("B3").Select
Do Until rst3.EOF
If .ActiveCell.Value = rst3!EmpRptID Then
.Worksheets("Sheet1").Columns(GetColumnLetter(.ActiveCell.Column)).Select
.CutCopyMode = 1
.Selection.Copy
.Worksheets("Sheet2").Select
.ActiveCell.PasteSpecial -4104
.ActiveCell.Offset(0, 1).Select
.Worksheets("Sheet1").Select
.Range("B3").Select
rst3.MoveNext
Else
.ActiveCell.Offset(0, 1).Select
End If
Loop
'Delete the first sheet
.Sheets("Sheet1").Delete
.Sheets("Sheet2").Select
'Create the Average Line value
.Range("A4").Select
If .ActiveCell.Value = "" Then .Rows(.ActiveCell.Row).Delete
Do Until .ActiveCell.Value = ""
.ActiveCell.Offset(1, 0).Select
Loop
intRow = .ActiveCell.Row
.Range("B" & intRow).Select
.ActiveCell.Value = "=Round(Sum(B4:S" & intRow - 1 & ")/
18,0)"
.ActiveCell.Value = .ActiveCell.Value2 'Make the formula
become a static number
.ActiveCell.AutoFill Destination:=.Range("B" & intRow & ":" &
strLetter & intRow), Type:=0
'Chart Creation
intRow = intRow - 1
.ActiveWorkbook.Charts.Add
After:=.Worksheets(.Worksheets.Count)
.ActiveChart.SetSourceData Source:=.Range("'Sheet2'!$A$3:$" &
strLetter & "$" & intRow)
.ActiveChart.ChartType = 52
.ActiveChart.HasTitle = True
.ActiveChart.ChartTitle.Text = "Individual Parts Chart" &
Chr(13) _
& "Completed Production Dates: " & datStart & " and " &
datEnd
.ActiveChart.SeriesCollection(1).Select
'Set the charts bar color
With .ActiveChart
For i = .SeriesCollection.Count To 1 Step -1
With .SeriesCollection(i)
Select Case .Name
Case "0EPS"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 1
.Pattern = 1
End With
Case "0LID"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 39
.Pattern = 1
End With
Case "0OPS"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 19
.Pattern = 1
End With
Case "DELI"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 35
.Pattern = 1
End With
Case "PEPS"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 8
.Pattern = 1
End With
.Interior.ColorIndex = 8
Case "0PPC"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 7
.Pattern = 1
End With
Case "CCUP"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 41
.Pattern = 1
End With
Case "0PET"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 4
.Pattern = 1
End With
Case "IDIN"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 27
.Pattern = 1
End With
Case "EXTF"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 3
.Pattern = 1
End With
Case "HAVI"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 43
.Pattern = 1
End With
Case "FILM"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 53
.Pattern = 1
End With
Case "Gloss"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 10
.Pattern = 1
End With
End Select
End With
Next i
End With
'Create the Average line in the chart
.ActiveChart.PlotArea.Select
.ActiveChart.SeriesCollection.NewSeries
y = .ActiveChart.SeriesCollection.Count
.ActiveChart.SeriesCollection(y).Values = "=Sheet2!R" &
intRow
+ 1 & "C2:R" & intRow + 1 & "C" & rst.Fields.Count
.ActiveChart.SeriesCollection(y).Name = "=""Average"""
.ActiveChart.SeriesCollection(y).Select
.ActiveChart.SeriesCollection(y).AxisGroup = 1
.ActiveChart.SeriesCollection(y).ChartType = 4
.ActiveChart.SeriesCollection(y).Border.ColorIndex = 1
If .ActiveChart.SeriesCollection.Count
= .ActiveChart.Legend.LegendEntries.Count Then
.ActiveChart.Legend.LegendEntries(y).Select
.Selection.Delete
End If
.ActiveChart.PlotArea.Select
.ActiveChart.Axes(1).Select
.ActiveChart.SeriesCollection(1).Select
.ActiveChart.SeriesCollection(1).XValues
= .Worksheets("Sheet2").Range("B3:S3")
'Generate Weight Factor Report
.Sheets("Sheet3").Select
.Range("A3").Select
.Worksheets("Sheet3").Columns("A").ColumnWidth = 15.71
.Worksheets("Sheet3").Columns("C").ColumnWidth = 8.43
Set rst = db.OpenRecordset("qryTechReport_Crosstab")
For Each fld In rst.Fields
.ActiveCell.Value = fld.Name
With .ActiveCell.Borders(9)
.LineStyle = 1
.ColorIndex = 0
.Weight = 2
End With
With .ActiveCell.Interior
.ColorIndex = 15
.Pattern = 1
.PatternColorIndex = -4105
End With
.ActiveCell.Offset(0, 1).Select
Next fld
strLetter = GetColumnLetter(.ActiveCell.Column - 1)
.ActiveCell.Offset(1, -(.ActiveCell.Column - 1)).Select
rst.MoveFirst
Do Until rst.EOF
For x = 0 To rst.Fields.Count - 1
.ActiveCell.Offset(0, x).Value = rst.Fields(x).Value
If x > 0 Then
If Not IsNull(rst.Fields(0).Value) Then
Set rst2 = db.OpenRecordset("SELECT WgtFtr
FROM tblWgtFtr WHERE" _
& " ProdLine = '" & rst.Fields(0).Value &
"'")
If .ActiveCell.Offset(0, x).Value * rst2!
WgtFtr <> 0 Then
.ActiveCell.Offset(0, x).Value2 =
"=Round(" & .ActiveCell.Offset(0, x).Value * rst2!WgtFtr & ",0)"
End If
Set rst2 = Nothing
End If
End If
Next x
rst.MoveNext
.ActiveCell.Offset(1, 0).Select
Loop
.Range("A4").Select
If .ActiveCell.Value = "" Then .Rows(.ActiveCell.Row).Delete
Do Until .ActiveCell.Value = ""
.ActiveCell.Offset(1, 0).Select
Loop
intRow = .ActiveCell.Row
.Range("B" & intRow).Select
.ActiveCell.Value = "=Sum(B4:B" & intRow - 1 & ")"
.ActiveCell.AutoFill Destination:=.Range("B" & intRow & ":" &
strLetter & intRow), Type:=0
.ActiveCell.Offset(1, 0).Select
.ActiveCell.Value = "=Round(Sum(B4:" & strLetter & intRow - 1
& ")/18,0)"
.ActiveCell.Value = .ActiveCell.Value2 'Make the formula
become a static number
.ActiveCell.AutoFill Destination:=.Range("B" & intRow + 1 &
":" & strLetter & intRow + 1), Type:=0
.Range("A4").Select
x = 0
Do Until .ActiveCell.Value = ""
.ActiveCell.Offset(1, 0).Select
x = x + 1
Loop
intRow = .ActiveCell.Row - 1
'Create the rank table
.Sheets.Add After:=.Sheets(.Sheets.Count)
.Sheets("Sheet1").Name = "Sheet4"
.Sheets("Sheet3").Select
.Range("B3").Select
Do Until .ActiveCell.Value = ""
.CutCopyMode = 1
.ActiveCell.Copy
.Sheets("Sheet4").Select
.Range("A1").Select
Do
If .ActiveCell.Value = "" Then
Exit Do
Else
.ActiveCell.Offset(1, 0).Select
End If
Loop
.ActiveCell.PasteSpecial -4163
.ActiveCell.Offset(0, 1).Select
.Sheets("Sheet3").Select
.ActiveCell.Offset(x + 1, 0).Copy
.Sheets("Sheet4").Select
.ActiveCell.PasteSpecial -4163
.ActiveCell.Offset(1, -1).Select
.Sheets("Sheet3").Select
.ActiveCell.Offset(0, 1).Select
Loop
With .Worksheets("Sheet4")
LastRow = .Cells(.Rows.Count, "A").End(-4162).Row
LastCol = .Cells(1, .Columns.Count).End(-4159).Column
Set RngToSort = .Range("A1", .Cells(LastRow, LastCol))
End With
With RngToSort
.Cells.Sort _
Key1:=.Columns(2), Order1:=2, _
header:=2, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=1
End With
'Order the Crosstab table
.Sheets.Add After:=.Sheets(.Sheets.Count)
.Sheets(.Sheets.Count).Name = "Sheet5"
.Sheets("Sheet3").Select
.Range("A1").Select
.CutCopyMode = 1
.ActiveCell.EntireColumn.Select
.ActiveCell.EntireColumn.Copy
.Sheets("Sheet5").Select
.ActiveCell.Range("A1").Select
.ActiveCell.PasteSpecial -4104
.ActiveCell.Offset(0, 1).Select
.Sheets("Sheet4").Select
intRow = .ActiveCell.Row - 1
.Range("A1").Select
strRank = .ActiveCell.Value
.Sheets("Sheet3").Select
.Range("B3").Select
Do
If .ActiveCell.Value = strRank Then
.CutCopyMode = 1
.ActiveCell.EntireColumn.Select
.ActiveCell.EntireColumn.Copy
.Sheets("Sheet5").Select
.ActiveCell.PasteSpecial -4104
.ActiveCell.Offset(0, 1).Select
.Sheets("Sheet4").Select
.ActiveCell.Offset(1, 0).Select
strRank = .ActiveCell.Value
If strRank = "" Then Exit Do
.Sheets("Sheet3").Select
.Range("B3").Select
Else
.ActiveCell.Offset(0, 1).Select
End If
Loop
'Generating Chart
.Sheets("Sheet5").Select
.Range("A4").Select
Do
If .ActiveCell.Value = "" Then
intRow = .ActiveCell.Row - 1
Exit Do
Else
.ActiveCell.Offset(1, 0).Select
End If
Loop
.Range("A3").Select
Do
If .ActiveCell.Value = "" Then
strLetter = GetColumnLetter(.ActiveCell.Column - 1)
Exit Do
Else
.ActiveCell.Offset(0, 1).Select
End If
Loop
.ActiveWorkbook.Charts.Add
After:=.Worksheets(.Worksheets.Count)
.ActiveChart.SetSourceData Source:=.Range("'Sheet5'!$A$3:$" &
strLetter & "$" & intRow)
.ActiveChart.ChartType = 52
.ActiveChart.HasTitle = True
.ActiveChart.ChartTitle.Text = "Weight Factor Chart" &
Chr(13)
_
& "Completed Production Dates: " & datStart & " and " &
datEnd
.ActiveChart.Legend.LegendEntries(.ActiveChart.SeriesCollection.Count).Sele
ct
'.Selection.Delete
'.ActiveChart.SeriesCollection(1).Select
'.Selection.Delete
'Set the charts bar color
With .ActiveChart
For i = .SeriesCollection.Count To 1 Step -1
With .SeriesCollection(i)
Select Case .Name
Case "0EPS"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 1
.Pattern = 1
End With
Case "0LID"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 39
.Pattern = 1
End With
Case "0OPS"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 19
.Pattern = 1
End With
Case "DELI"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 35
.Pattern = 1
End With
Case "PEPS"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 8
.Pattern = 1
End With
.Interior.ColorIndex = 8
Case "0PPC"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 7
.Pattern = 1
End With
Case "CCUP"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 41
.Pattern = 1
End With
Case "0PET"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 4
.Pattern = 1
End With
Case "IDIN"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 27
.Pattern = 1
End With
Case "EXTF"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 3
.Pattern = 1
End With
Case "HAVI"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 43
.Pattern = 1
End With
Case "FILM"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 53
.Pattern = 1
End With
Case "Gloss"
.Select
With .Border
.Weight = 1
.LineStyle = -4142
End With
.Shadow = False
.InvertIfNegative = False
With .Interior
.ColorIndex = 10
.Pattern = 1
End With
End Select
End With
Next i
End With
'Create the Average line in the chart
.ActiveChart.PlotArea.Select
.ActiveChart.SeriesCollection.NewSeries
y = .ActiveChart.SeriesCollection.Count
.ActiveChart.SeriesCollection(y).Values = "=Sheet5!R" &
intRow
+ 2 & "C2:R" & intRow + 2 & "C" & rst.Fields.Count
.ActiveChart.SeriesCollection(y).Name = "=""Average"""
.ActiveChart.SeriesCollection(y).Select
.ActiveChart.SeriesCollection(y).AxisGroup = 1
.ActiveChart.SeriesCollection(y).ChartType = 4
.ActiveChart.SeriesCollection(y).Border.ColorIndex = 1
If .ActiveChart.SeriesCollection.Count
= .ActiveChart.Legend.LegendEntries.Count Then
.ActiveChart.Legend.LegendEntries(y).Select
.Selection.Delete
End If
.ActiveChart.PlotArea.Select
.ActiveChart.Axes(1).Select
.ActiveChart.SeriesCollection(1).XValues
= .Worksheets("Sheet4").Range("A1:A18")
'Unlink the chart from the data & remove Module1 from the
Excel VBE.
'http://www.ozgrid.com/VBA/delete-module.htm
.Charts("Chart1").Select
.Run ("DelinkChartFromData")
.Charts("Chart2").Select
.Run ("DelinkChartFromData")
Set vbCom = .VBE.ActiveVBProject.VBComponents
vbCom.Remove VBComponent:=vbCom.Item("Module1")
Set vbCom = Nothing
'Save the Excel sheet
.Charts("Chart1").Select
strPath = "G:\" & Month(Date) & "_" & Day(Date) & "_" &
Year(Date) & ".xls"
If .Version = "12.0" Then
.ActiveWorkbook.SaveAs strPath
Else
.ActiveWorkbook.SaveAs strPath, 43
End If
End With
Call TechWeightFactor(strPath)
xl.Visible = True
xl.DisplayAlerts = True
xl.ScreenUpdating = True
xl.Interactive = True
Set xl = Nothing
Set rst = Nothing
Set rst2 = Nothing
Set rst3 = Nothing
Set db = Nothing
GetTechnicianReport_Err_Exit:
Exit Sub
GetTechnicianReport_Err:
MsgBox Err.Number & " - " & Err.Description
Resume GetTechnicianReport_Err_Exit
End Sub