Sub CreateKPIReport()
Dim xlBookStudent As Excel.Workbook
Dim xlSheetStudent As Excel.Worksheet
Dim xlBookSource As Excel.Workbook
Dim xlSheetSource As Excel.Worksheet
Dim xlBookDest As Excel.Workbook
Dim xlSheetDest As Excel.Worksheet
Dim xlSheetOverdue As Excel.Worksheet
Dim xlBookItem As Excel.Workbook
Dim xlSheetItem As Excel.Worksheet
Dim xlImpactSheetDest As Excel.Worksheet
Dim xlDebug As Excel.Worksheet
Dim xlBookDebug As Excel.Workbook
Dim RowCountSource As Long
Dim RowCountDest As Integer
Dim RowCountOverdue As Integer
Dim ItemRowCountDest As Long
Dim ItemRowCountSource As Long
Dim TrainingRowCount As Long
Dim NewRowCountDest As Integer
Dim NewRowCountSource As Integer
Dim NewItemRowCountDest As Integer
Dim CreditHourValue As Double
Dim DebugCounter As Integer
Dim SourceItemCounter As Long
Dim ImpactCount As Integer
Dim ColCountSource As Integer
Dim ColCountDest As Integer
Dim CurValue02 As String
Dim CurValue06 As String
Dim i As Integer
Dim Counter As Integer
Dim ImpactCounter As Integer
Dim TabName As String
Dim fn As Variant
Dim fn1 As Variant
Dim fn3 As Variant
Dim CurValue10 As Double
fn = Application.GetOpenFilename("Excel-files,*.xls;*.csv", _
1, "Select Student Learning Plan File To Open", , False)
If TypeName(fn) = "Boolean" Then Exit Sub
Set xlBookSource = Workbooks.Open(fn)
Set xlSheetSource = xlBookSource.Worksheets(1)
fn1 = Application.GetOpenFilename("Excel-files,*.xls;*.csv", _
1, "Select Student Account File To Open", , False)
If TypeName(fn1) = "Boolean" Then Exit Sub
Set xlBookStudent = Workbooks.Open(fn1)
Set xlSheetStudent = xlBookStudent.Worksheets(1)
fn3 = Application.GetOpenFilename("Excel-files,*.xls;*.csv", _
1, "Select Item Plan File To Open", , False)
If TypeName(fn3) = "Boolean" Then Exit Sub
Set xlBookItem = Workbooks.Open(fn3)
Set xlSheetItem = xlBookItem.Worksheets(1)
Set xlDebug = ThisWorkbook.Worksheets("Debug")
Set xlSheetDest = ThisWorkbook.Worksheets("Training Report")
xlSheetDest.Activate
xlSheetDest.Cells.Select
Selection.Clear
Set xlSheetOverdue = ThisWorkbook.Worksheets("Overdue Items")
xlSheetOverdue.Activate
xlSheetOverdue.Cells.Select
Selection.Clear
Set xlImpactSheetDest = ThisWorkbook.Worksheets("Training Impact")
xlImpactSheetDest.Activate
xlImpactSheetDest.Cells.Select
Selection.Clear
Set xlDebug = ThisWorkbook.Worksheets("Debug")
xlDebug.Activate
xlDebug.Cells.Select
Selection.Clear
thisDate = Date
thisYear = DatePart("yyyy", thisDate)
thisMonth = DatePart("m", thisDate)
ImpactCounter = 1
xlImpactSheetDest.Cells(ImpactCounter, 1).Value = "Item ID"
xlImpactSheetDest.Cells(ImpactCounter, 2).Value = "Item Title"
xlImpactSheetDest.Cells(ImpactCounter, 3).Value = "Credit Hours"
ItemRowCountDest = 2
ItemRowCountSource = 2
ItemLastRow = LastCell(xlSheetItem).Row
' Copy Training IDs & Training Titles into Training Impact where Credit Hours is existing
For ItemRowCountSource = 2 To ItemLastRow
CurValue03 = xlSheetItem.Cells(ItemRowCountSource, 1)
CurValue10 = xlSheetItem.Cells(ItemRowCountSource, 35).Value
If (Len(CurValue03) > 0) Then
If (CurValue10 > 0) Then
ItemRowCountDest = ItemRowCountDest + 1
xlImpactSheetDest.Cells(ItemRowCountDest, 1).Value = xlSheetItem.Cells(ItemRowCountSource, 1).Value
xlImpactSheetDest.Cells(ItemRowCountDest, 2).Value = xlSheetItem.Cells(ItemRowCountSource, 2).Value
xlImpactSheetDest.Cells(ItemRowCountDest, 3).Value = CurValue10
End If
End If
Next ItemRowCountSource
Counter = 1
xlSheetDest.Cells(Counter, 1).Value = "Employee ID"
xlSheetDest.Cells(Counter, 2).Value = "User Name"
xlSheetDest.Cells(Counter, 3).Value = "Supervisor Name"
xlSheetDest.Cells(Counter, 4).Value = "Overdue"
xlSheetDest.Cells(Counter, 5).Value = "Due This Month"
xlSheetDest.Cells(Counter, 6).Value = "Due In 60 Days"
xlSheetDest.Cells(Counter, 7).Value = "Due In 90 Days"
xlSheetDest.Cells(Counter, 8).Value = "Due by Year End (" & thisYear & ")"
xlSheetDest.Cells(Counter, 9).Value = "Future (>" & thisYear & ")"
xlSheetDest.Cells(Counter, 10).Value = "Total"
RowCountDest = 2
RowCountOverdue = 0
SourceItemCounter = 2
DebugCounter = 1
PlanLastRow = LastCell(xlSheetSource).Row
ImpactCount = 3
For RowCountSource = 2 To PlanLastRow
CurValue02 = xlSheetSource.Cells(RowCountSource, 2).Value
If (Len(CurValue02) > 0) Then
If (xlSheetDest.Cells(RowCountDest, 2).Value <> CurValue02) Then
RowCountDest = RowCountDest + 1
xlSheetDest.Cells(RowCountDest, 1).Value = xlSheetSource.Cells(RowCountSource, 1).Value
xlSheetDest.Cells(RowCountDest, 2).Value = CurValue02
End If
'Begin here to test debug in returning title time and student
CreditHourValue = ImpactVLookup(xlSheetSource.Cells(RowCountSource, 3), "A:C", xlImpactSheetDest)
If (InStr(CurValue02, "MOHITE, SANDEEP")) Then
xlDebug.Cells(DebugCounter, 1).Value = xlSheetSource.Cells(RowCountSource, 2).Value
xlDebug.Cells(DebugCounter, 2).Value = xlSheetSource.Cells(RowCountSource, 3).Value
xlDebug.Cells(DebugCounter, 3).Value = CreditHourValue
DebugCounter = DebugCounter + 1
End If
CurValue06 = xlSheetSource.Cells(RowCountSource, 6).Value
If (Len(CurValue06) > 0) Then
Select Case CurValue06
Case Is <= 0
xlSheetDest.Cells(RowCountDest, 4).Value = xlSheetDest.Cells(RowCountDest, 4).Value + 1
xlSheetDest.Cells(RowCountDest, 8).Value = xlSheetDest.Cells(RowCountDest, 8).Value + 1
RowCountOverdue = RowCountOverdue + 1
xlSheetOverdue.Cells(RowCountOverdue, 1).Value = xlSheetSource.Cells(RowCountSource, 2)
xlSheetOverdue.Cells(RowCountOverdue, 2).Value = xlSheetSource.Cells(RowCountSource, 3)
OverdueValue = CreditHourValue + OverdueValue
xlSheetOverdue.Cells(RowCountOverdue, 3).Value = xlSheetSource.Cells(RowCountSource, 4)
Case Is > 0
CurValue05 = xlSheetSource.Cells(RowCountSource, 5).Value
dueYear = DatePart("yyyy", CurValue05)
dueMonth = DatePart("m", CurValue05)
If ((thisYear = dueYear) And (thisMonth = dueMonth)) Then
xlSheetDest.Cells(RowCountDest, 5).Value = xlSheetDest.Cells(RowCountDest, 5).Value + 1
DueMonthValue = CreditHourValue + DueMonthValue
If (InStr(CurValue02, "MOHITE, SANDEEP")) Then
xlDebug.Cells(DebugCounter, 1).Value = xlSheetSource.Cells(RowCountSource, 2).Value
xlDebug.Cells(DebugCounter, 2).Value = xlSheetSource.Cells(RowCountSource, 3).Value
xlDebug.Cells(DebugCounter, 4).Value = "Month"
xlDebug.Cells(DebugCounter, 3).Value = CreditHourValue
DebugCounter = DebugCounter + 1
End If
ElseIf (CurValue05 < (thisDate + 60)) Then
xlSheetDest.Cells(RowCountDest, 6).Value = xlSheetDest.Cells(RowCountDest, 6).Value + 1
DueSixtyValue = CreditHourValue + DueSixtyValue
If (InStr(CurValue02, "MOHITE, SANDEEP")) Then
xlDebug.Cells(DebugCounter, 1).Value = xlSheetSource.Cells(RowCountSource, 2).Value
xlDebug.Cells(DebugCounter, 2).Value = xlSheetSource.Cells(RowCountSource, 3).Value
xlDebug.Cells(DebugCounter, 5).Value = "60 Days"
xlDebug.Cells(DebugCounter, 3).Value = CreditHourValue
DebugCounter = DebugCounter + 1
End If
ElseIf (CurValue05 < (thisDate + 90)) Then
xlSheetDest.Cells(RowCountDest, 7).Value = xlSheetDest.Cells(RowCountDest, 7).Value + 1
DueNinetyValue = CreditHourValue + DueNinetyValue
If (InStr(CurValue02, "MOHITE, SANDEEP")) Then
xlDebug.Cells(DebugCounter, 1).Value = xlSheetSource.Cells(RowCountSource, 2).Value
xlDebug.Cells(DebugCounter, 2).Value = xlSheetSource.Cells(RowCountSource, 3).Value
xlDebug.Cells(DebugCounter, 6).Value = "90 Days"
xlDebug.Cells(DebugCounter, 3).Value = CreditHourValue
DebugCounter = DebugCounter + 1
End If
ElseIf (thisYear = dueYear) Then
xlSheetDest.Cells(RowCountDest, 8).Value = xlSheetDest.Cells(RowCountDest, 8).Value + 1
DueYearValue = CreditHourValue + DueYearValue
If (InStr(CurValue02, "MOHITE, SANDEEP")) Then
xlDebug.Cells(DebugCounter, 1).Value = xlSheetSource.Cells(RowCountSource, 2).Value
xlDebug.Cells(DebugCounter, 2).Value = xlSheetSource.Cells(RowCountSource, 3).Value
xlDebug.Cells(DebugCounter, 7).Value = "Year"
xlDebug.Cells(DebugCounter, 3).Value = CreditHourValue
DebugCounter = DebugCounter + 1
End If
Else
xlSheetDest.Cells(RowCountDest, 9).Value = xlSheetDest.Cells(RowCountDest, 9).Value + 1
DueFutureValue = CreditHourValue + DueFutureValue
If (InStr(CurValue02, "MOHITE, SANDEEP")) Then
xlDebug.Cells(DebugCounter, 1).Value = xlSheetSource.Cells(RowCountSource, 2).Value
xlDebug.Cells(DebugCounter, 2).Value = xlSheetSource.Cells(RowCountSource, 3).Value
xlDebug.Cells(DebugCounter, 8).Value = "Future"
xlDebug.Cells(DebugCounter, 3).Value = CreditHourValue
DebugCounter = DebugCounter + 1
End If
End If
xlSheetDest.Cells(RowCountDest, 10).Value = xlSheetDest.Cells(RowCountDest, 10).Value + 1
DueTotalValue = CreditHourValue + DueTotalValue
Case Else
End Select
End If
Else
Exit For
End If
Next RowCountSource
' lookup supervisor for each student in report
For i = 2 To RowCountDest
xlSheetDest.Cells(i, 3).Value = RowVLookup(xlSheetDest.Cells(i, 2).Value, "B:N", xlSheetStudent)
Next i
xlSheetDest.Activate
For i = 2 To Counter
myRange1 = "B" & i
myRange2 = "B" & i & ":J" & i
Range(myRange1).Select
Selection.AutoFill Destination:=Range(myRange2), Type:=xlFillDefault
Next i
Columns("A:J").Select
Selection.Sort Key1:=Range("A3"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("A1:J1").Select
With Selection.Interior
.ColorIndex = 37
.Pattern = xlSolid
End With
Rows("1:1").RowHeight = 50
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Font.Bold = True
Range("A1:J" & RowCountDest).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Range("A3").Select
' Insert Row Above Data compiled from first Macro
Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Select
xlSheetDest.Cells(1, 1) = "Business Unit: " + xlSheetStudent.Cells(2, 7)
Range("D1").Select
' Insert Impact Data
xlSheetDest.Cells(1, 4) = OverdueValue
xlSheetDest.Cells(1, 5) = DueMonthValue
xlSheetDest.Cells(1, 6) = DueSixtyValue
xlSheetDest.Cells(1, 7) = DueNinetyValue
xlSheetDest.Cells(1, 8) = DueYearValue
xlSheetDest.Cells(1, 9) = DueFutureValue
xlSheetDest.Cells(1, 10) = OverdueValue + DueMonthValue + DueSixtyValue + DueNinetyValue + DueYearValue + DueFutureValue
Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Select
xlSheetDest.Cells(1, 4) = "Overdue Hours"
xlSheetDest.Cells(1, 5) = "Next 30 Days"
xlSheetDest.Cells(1, 6) = "60 Days"
xlSheetDest.Cells(1, 7) = "90 Days"
xlSheetDest.Cells(1, 8) = "" & thisYear & ""
xlSheetDest.Activate
For i = 2 To Counter
myRange1 = "B" & i
myRange2 = "B" & i & ":J" & i
Range(myRange1).Select
Selection.AutoFill Destination:=Range(myRange2), Type:=xlFillDefault
Next i
Range("A1:J2").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("D1:J2").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("K1").Select
Columns("B:B").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("D:D").EntireColumn.AutoFit
Columns("E:E").EntireColumn.AutoFit
Columns("F:F").EntireColumn.AutoFit
Columns("G:G").EntireColumn.AutoFit
Columns("H:H").EntireColumn.AutoFit
Columns("I:I").EntireColumn.AutoFit
Range("A1:J2").Select
Selection.Font.Bold = True
Range("D1:J2").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
xlSheetDest.Cells(RowCountDest + 2, 3) = "Total"
xlSheetDest.Cells(RowCountDest + 2, 4) = "=SUM(D4:D" & RowCountDest & ")"
xlSheetDest.Cells(RowCountDest + 2, 5) = "=SUM(E4:E" & RowCountDest & ")"
xlSheetDest.Cells(RowCountDest + 2, 6) = "=SUM(F4:F" & RowCountDest & ")"
xlSheetDest.Cells(RowCountDest + 2, 7) = "=SUM(G4:G" & RowCountDest & ")"
xlSheetDest.Cells(RowCountDest + 2, 8) = "=SUM(H4:H" & RowCountDest & ")"
xlSheetDest.Cells(RowCountDest + 2, 9) = "=SUM(I4:I" & RowCountDest & ")"
xlBookSource.Close SaveChanges:=False
End Sub
Sub DeleteAllCode()
'Trust Access To Visual Basics Project must be enabled.
'From Excel: Tools | Macro | Security | Trusted Sources
Dim x As Integer
Dim Proceed As VbMsgBoxResult
Dim Prompt As String
Dim Title As String
'Prompt = "Are you certain that you want to delete all the VBA Code from " & ActiveWorkbook.Name & "?"
'Title = "Verify Procedure"
'Proceed = MsgBox(Prompt, vbYesNo + vbQuestion, Title)
'If Proceed = vbNo Then
'MsgBox "Procedure Canceled", vbInformation, "Procedure Aborted"
'Exit Sub
'End If
On Error Resume Next
With ActiveWorkbook.VBProject
For x = .VBComponents.Count To 1 Step -1
.VBComponents.Remove .VBComponents(x)
Next x
For x = .VBComponents.Count To 1 Step -1
.VBComponents(x).CodeModule.DeleteLines _
1, .VBComponents(x).CodeModule.CountOfLines
Next x
End With
On Error GoTo 0
End Sub
Call DeleteAllCode
PathName = ThisWorkbook.Path & "z:\\m...\...\..."
NewFileName = PathName & "\" & TargetYear & TargetSemester & " Weekly_Sheets " & TargetStudentType & ".xlsx"
' ThisWorkbook.BuiltinDocumentProperties("Comments") = ThisWorkbook.Name
' Create new file
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=NewFileName, _
FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
Application.DisplayAlerts = True
End Sub