Sub Universal_Trend()
'
' '=======================================================================
'For use with FAR Removal Trend.xls Access export file.
'Column order is as follows:
'YEAR-MONTH,PN,NOMENCLATURE,CUSTID,LCN,INH,NFF,IND,OPEN,UH,
'PREDICTED MTBF,VENDOR,MTFB Y-N, MTBR Y-N, PPT Y-N, # of Months, Customer
'=======================================================================
'=======================================================================
'Moves Query - Trend data to template workbook
'=======================================================================
Application.ScreenUpdating = False
On Error GoTo Error_Handler
Windows("FAR Removal Trend.xls").Activate
Sheets("FAR Removal Trend").Move After:=Workbooks( _
"060927_Universal Trend Template1").Sheets("Pie Chart Data")
numberofrowsA = Cells(65536, 1).End(xlUp).Row
'=======================================================================
'Looks for multiple part numbers and combines the multiple part number
'fields
'=======================================================================
Columns("B:B").Sort Key1:=Range("B1"), Order1:=xlDescending, Header:=xlYes
x = 2
If Cells(x, 2) = vbNullString Then
Application.ScreenUpdating = True
no_data = MsgBox("No data to trend in date range selected!", vbOKOnly, "Data Check")
GoTo cleanup
End If
Range("AA1").Value = Range("B1").Value
' Do the Advanced Filter
Range("A1").CurrentRegion.AdvancedFilter xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True
' Column 27 equals column AA
numberofrowsB = Cells(65536, 27).End(xlUp).Row
For x = 2 To numberofrowsB
If Cells(x + 1, 27) = vbNullString Then
Cells(x, 27).Copy Range("B2:B" & numberofrowsA)
Columns("AA:AA").ClearContents
Exit For
Else
Cells(x + 1, 27).Formula = Cells(x, 27) & ", " & Cells(x + 1, 27)
End If
Next
'=======================================================================
'Looks for multiple FAR records in a month for a single customer and
'combines the the FAR record count
'=======================================================================
For x = 2 To numberofrowsA
If Cells(x, 1) = Cells(x + 1, 1) And Cells(x, 4) <> vbNullString And _
Cells(x, 4) = Cells(x + 1, 4) Then
Cells(x, 6).Formula = Cells(x, 6) + Cells(x + 1, 6)
Cells(x, 7).Formula = Cells(x, 7) + Cells(x + 1, 7)
Cells(x, 8).Formula = Cells(x, 8) + Cells(x + 1, 8)
Cells(x, 9).Formula = Cells(x, 9) + Cells(x + 1, 9)
Cells(x + 1, 1).Select
ActiveCell.EntireRow.Delete (up)
x = x - 1
End If
Next
'======================================================================
'Checks data set for correct CUSTIDs and makes corrections if needed
'======================================================================
Sheets("FAR Removal Trend").Select
numberofrowsA = Cells(65536, 1).End(xlUp).Row
x = 2
Do Until Cells(x, 4) = vbNullString
If Cells(x, 4) <> "AMI" Then
Cells(x, 4).EntireRow.Select
Selection.Insert Shift:=xlDown
Selection.Interior.ColorIndex = xlNone
Cells(x, 4).FormulaR1C1 = "AMI"
Cells(x + 1, 1).Copy Cells(x, 1)
Cells(x + 1, 2).Copy Cells(x, 2)
Application.CutCopyMode = False
End If
If Cells(x + 1, 4) <> "RAF" Then
Cells(x + 1, 4).EntireRow.Insert Shift:=xlDown
Cells(x + 1, 4).FormulaR1C1 = "RAF"
Cells(x, 1).Copy Cells(x + 1, 1)
Application.CutCopyMode = False
End If
If Cells(x + 2, 4) <> "USAF-CI" Then
Cells(x + 2, 4).EntireRow.Insert Shift:=xlDown
Cells(x + 2, 4).FormulaR1C1 = "USAF-CI"
Cells(x, 1).Copy Cells(x + 2, 1)
Application.CutCopyMode = False
End If
If Cells(x + 3, 4) <> "USAF-KE" Then
Cells(x + 3, 4).EntireRow.Insert Shift:=xlDown
Cells(x + 3, 4).FormulaR1C1 = "USAF-KE"
Cells(x, 1).Copy Cells(x + 3, 1)
Application.CutCopyMode = False
End If
If Cells(x + 4, 4) <> "USAF-LR" Then
Cells(x + 4, 4).EntireRow.Insert Shift:=xlDown
Cells(x + 4, 4).FormulaR1C1 = "USAF-LR"
Cells(x, 1).Copy Cells(x + 4, 1)
Application.CutCopyMode = False
End If
If Cells(x + 5, 4) <> "USAF-MD" Then
Cells(x + 5, 4).EntireRow.Insert Shift:=xlDown
Cells(x + 5, 4).FormulaR1C1 = "USAF-MD"
Cells(x, 1).Copy Cells(x + 5, 1)
Application.CutCopyMode = False
End If
If Cells(x + 6, 4) <> "USAF-PA" Then
Cells(x + 6, 4).EntireRow.Insert Shift:=xlDown
Cells(x + 6, 4).FormulaR1C1 = "USAF-PA"
Cells(x, 1).Copy Cells(x + 6, 1)
Application.CutCopyMode = False
End If
If Cells(x + 7, 4) <> "USAF-RI" Then
Cells(x + 7, 4).EntireRow.Insert Shift:=xlDown
Cells(x + 7, 4).FormulaR1C1 = "USAF-RI"
Cells(x, 1).Copy Cells(x + 7, 1)
Application.CutCopyMode = False
End If
x = x + 8
Loop
'======================================================================
'fills in Nomenclature, LCN, Predicted & Vendor field
'======================================================================
Sheets("FAR Removal Trend").Select
numberofrowsA = Cells(65536, 1).End(xlUp).Row
For x = 2 To numberofrowsA
If Cells(x, 3) <> vbNullString Then
Cells(x, 3).Copy Range("C2:C" & numberofrowsA)
Cells(x, 5).Copy Range("E2:E" & numberofrowsA)
Cells(x, 11).Copy Range("K2:K" & numberofrowsA)
Cells(x, 12).Copy Range("L2:L" & numberofrowsA)
Cells(x, 13).Copy Range("M2:M" & numberofrowsA)
Cells(x, 14).Copy Range("N2:N" & numberofrowsA)
Cells(x, 15).Copy Range("O2:O" & numberofrowsA)
Cells(x, 16).Copy Range("P2:P" & numberofrowsA)
Cells(x, 17).Copy Range("Q2:Q" & numberofrowsA)
x = numberofrowsA
End If
Next
'=======================================================================
'Copies data to Pie Chart Data sheet
'=======================================================================
y = 2
numberofrowsA = Cells(65536, 1).End(xlUp).Row
For x = 2 To numberofrowsA
If Cells(x, 1) <> Cells(x + 1, 1) Then
Range("A" & x, "L" & x - 7).Copy Sheets("Pie Chart Data").Cells(y, 1)
y = y + 9
Sheets("FAR Removal Trend").Select
End If
Next
'=======================================================================
'Loads the cell formulas used in the ratio process on each ratio trend
'worksheet.
'=======================================================================
Dim TL As Integer
Dim TLA As Integer
Dim TLB As Integer
Dim TLC As Integer
Dim TLD As Integer
Dim TLE As Integer
Dim InhSum As String
Dim NffSum As String
Dim IndSum As String
Dim OpenSum As String
Dim Total_Fars As String
Dim Total_Ratio_Open As String
Dim Cat_Percent As String
Dim Total_Cat As String
Dim Ratio_Inh As String
Dim Ratio_Nff As String
Dim Ratio_Ind As String
Dim Ratio_Total As String 'total used for ratio method
Dim Open_Inh As String
Dim Open_Nff As String
Dim Open_Ind As String
TL = Sheets("FAR Removal Trend").Cells(2, 16) '# of months column
TLA = 48 - TL
TLB = TL + 2
TLC = TL + 3
TLD = TL + 4
TLE = TL + 5
WorksheetArray = Array("Ratioed Trend Data", "RAF Ratioed Trend Data", "USAF Ratioed Trend Data", _
"AMI Ratioed Trend Data")
CustomerArray = Array("All Customers", "RAF", "USAF", "AMI")
For z = 0 To UBound(CustomerArray)
Sheets(WorksheetArray(z)).Select
Ratio_Total = "=IF(OR(SUM(F" & 38 - TLA & ":F" & 49 - TLA & ")>0,SUM(G" & 38 - TLA & ":G" & 49 - TLA & _
")>0,SUM(H" & 38 - TLA & ":H" & 49 - TLA & ")>0),SUM(E" & 38 - TLA & ":E" & 49 - TLA & "),SUM(E2:E" & 49 - TLA & "))"
Cells(TLB, 4).Formula = Ratio_Total ' total used for ratio method
Total_Fars = "=SUM(E2:E" & 49 - TLA & ")"
Cells(TLB, 5).Formula = Total_Fars ' summation of Total column
Cat_Percent = "=SUM(F" & TLB & ":H" & TLB & ")/D" & TLB
Cells(TLC, 5).Formula = Cat_Percent
InhSum = "=IF(OR(SUM(F" & 38 - TLA & ":F" & 49 - TLA & ")>0,SUM(G" & 38 - TLA & ":G" & 49 - TLA & _
")>0,SUM(H" & 38 - TLA & ":H" & 49 - TLA & ")>0),SUM(F" & 38 - TLA & ":F" & 49 - TLA & "),SUM(F2:F" & 49 - TLA & "))"
Cells(TLB, 6).Formula = InhSum ' summation of Inherent records
Total_Cat = "=SUM(F" & TLB & ":H" & TLB & ")"
Cells(TLC, 6).Formula = Total_Cat
Ratio_Inh = "=F" & TLB & "/F" & TLC ' Inherent ratio
Cells(TLD, 6).Formula = Ratio_Inh
Open_Inh = "=ROUNDUP(I" & TLB & "*F" & TLD & ",2)" 'Inherent portion of Opens based on ratio
Cells(TLE, 6).Formula = Open_Inh
NffSum = "=IF(OR(SUM(F" & 38 - TLA & ":F" & 49 - TLA & ")>0,SUM(G" & 38 - TLA & ":G" & 49 - TLA & _
")>0,SUM(H" & 38 - TLA & ":H" & 49 - TLA & ")>0),SUM(G" & 38 - TLA & ":G" & 49 - TLA & "),SUM(G2:G" & 49 - TLA & "))"
Cells(TLB, 7).Formula = NffSum ' summation of NFF records
Ratio_Nff = "=G" & TLB & "/F" & TLC ' Inherent ratio
Cells(TLD, 7).Formula = Ratio_Nff
Open_Nff = "=ROUNDUP(I" & TLB & "*G" & TLD & ",2)" 'Nff portion of Opens based on ratio
Cells(TLE, 7).Formula = Open_Nff
IndSum = "=IF(OR(SUM(F" & 38 - TLA & ":F" & 49 - TLA & ")>0,SUM(G" & 38 - TLA & ":G" & 49 - TLA & _
")>0,SUM(H" & 38 - TLA & ":H" & 49 - TLA & ")>0),SUM(H" & 38 - TLA & ":H" & 49 - TLA & "),SUM(H2:H" & 49 - TLA & "))"
Cells(TLB, 8).Formula = IndSum ' summation of Ind records
Ratio_Ind = "=H" & TLB & "/F" & TLC ' Induced ratio
Cells(TLD, 8).Formula = Ratio_Ind
Open_Ind = "=ROUNDUP(I" & TLB & "*H" & TLD & ",2)" 'Induced portion of Opens based on ratio
Cells(TLE, 8).Formula = Open_Ind
OpenSum = "=SUM(I2:I" & 49 - TLA & ")"
Cells(TLB, 9).Formula = OpenSum ' summation of Open records
Total_Ratio_Open = "=SUM(F" & TLE & ":H" & TLE & ")"
Cells(TLE, 9).Formula = Total_Ratio_Open
'=======================================================================
'Replaces the formulas with the static values and checks the percentage
'of dispositioned records (All Customers)
'=======================================================================
If Cells(TLB, 6) <> 0 Or Cells(TLB, 7) <> 0 Or Cells(TLB, 8) <> 0 Then
numberofrowsA = TL + 1
Cells(TLD, 10).FormulaR1C1 = "inh"
Range(Cells(TLD, 6), Cells(TLE, 9)).Value = Range(Cells(TLD, 6), Cells(TLE, 9)).Value 'works like paste Special Values
Cells(TLC, 5).Value = Cells(TLC, 5).Value
Cells(TLB, 9).Value = Cells(TLB, 9).Value
Cells(TLC, 5).Select
If Cells(TLC, 5) < 0.33 Then
Application.ScreenUpdating = True
ratio = MsgBox(CustomerArray(z) & " categorized records less than 33% - Do you want to continue with Ratio Process?", vbYesNo, "Ratio Process")
If ratio = 7 Then
Application.ScreenUpdating = False
GoTo next_analysis
End If
Application.ScreenUpdating = False
End If
'=======================================================================
'Dispositions opens as long as the ratio value is greater than .99
'(All Customers)
'=======================================================================
For a = 2 To numberofrowsA
Cells(a, 9).Select
If Cells(TLE, 6) > 0.99 Then
Cells(TLD, 10).FormulaR1C1 = "inh"
ElseIf Cells(TLE, 7) > 0.99 Then
Cells(TLD, 10).FormulaR1C1 = "nff"
ElseIf Cells(TLE, 8) > 0.99 Then
Cells(TLD, 10).FormulaR1C1 = "ind"
End If
If Cells(a, 9) > 0 Then
Do While Cells(a, 9).Value <> 0
If Cells(TLD, 10) = "inh" And Cells(TLE, 6).Value > 0.99 Then
Cells(a, 6).Value = Cells(a, 6).Value + 1
Cells(a, 9).Value = Cells(a, 9).Value - 1
Cells(TLE, 6).Value = Cells(TLE, 6).Value - 1
If Cells(TLE, 7) > 0.99 Then
Cells(TLD, 10).FormulaR1C1 = "nff"
ElseIf Cells(TLE, 8) > 0.99 Then
Cells(TLD, 10).FormulaR1C1 = "ind"
ElseIf Cells(TLE, 6) > 0.99 Then
Cells(TLD, 10).FormulaR1C1 = "inh"
End If
Else
If Cells(TLD, 10) = "nff" And Cells(TLE, 7) > 0.99 Then
Cells(a, 7).Value = Cells(a, 7).Value + 1
Cells(a, 9).Value = Cells(a, 9).Value - 1
Cells(TLE, 7).Value = Cells(TLE, 7).Value - 1
If Cells(TLE, 8) > 0.99 Then
Cells(TLD, 10).FormulaR1C1 = "ind"
ElseIf Cells(TLE, 6) > 0.99 Then
Cells(TLD, 10).FormulaR1C1 = "inh"
ElseIf Cells(TLE, 7) > 0.99 Then
Cells(TLD, 10).FormulaR1C1 = "nff"
End If
Else
If Cells(TLD, 10) = "ind" And Cells(TLE, 8) > 0.99 Then
Cells(a, 8).Value = Cells(a, 8).Value + 1
Cells(a, 9).Value = Cells(a, 9).Value - 1
Cells(TLE, 8).Value = Cells(TLE, 8).Value - 1
If Cells(TLE, 6) > 0.99 Then
Cells(TLD, 10).FormulaR1C1 = "inh"
ElseIf Cells(TLE, 7) > 0.99 Then
Cells(TLD, 10).FormulaR1C1 = "nff"
ElseIf Cells(TLE, 8) > 0.99 Then
Cells(TLD, 10).FormulaR1C1 = "ind"
End If
Else
Cells(TLD, 10).FormulaR1C1 = "inh"
End If
End If
End If
'=======================================================================
'Dispositions the last open record acording to the greatest percent
'remaining less than 1 (All Customers)
'=======================================================================
If Cells(TLE, 6) <= 0.99 And Cells(TLE, 7) <= 0.99 And Cells(TLE, 6) <= 0.99 Then
If Cells(a, 9) <> 0 Then
If Cells(TLE, 6) >= Cells(TLE, 7) And Cells(TLE, 6) >= Cells(TLE, 8) Then
Cells(TLD, 10).FormulaR1C1 = "inh"
Cells(a, 6).Value = Cells(a, 6).Value + 1
Cells(a, 9).Value = Cells(a, 9).Value - 1
Cells(TLE, 6).Value = Cells(TLE, 6).Value - 1
Else
Cells(TLD, 10).FormulaR1C1 = "nff"
If Cells(TLE, 7) >= Cells(TLE, 8) Then
Cells(a, 7).Value = Cells(a, 7).Value + 1
Cells(a, 9).Value = Cells(a, 9).Value - 1
Cells(TLE, 7).Value = Cells(TLE, 7).Value - 1
Else
Cells(TLD, 10).FormulaR1C1 = "ind"
Cells(a, 8).Value = Cells(a, 8).Value + 1
Cells(a, 9).Value = Cells(a, 9).Value - 1
Cells(TLE, 8).Value = Cells(TLE, 8).Value - 1
End If
End If
End If
End If
Loop
End If
Next
Else
If z = 0 Then
no_data = MsgBox("No categorized records for all customers", vbOKOnly, "Data Check")
End
Else
'When only one customer is run. Prevents warnings for all customers except the one customer requested
Select Case Sheets("FAR Removal Trend").Cells(2, 17) 'Customer ID
Case "All Customers"
no_data = MsgBox("No categorized records for " & CustomerArray(z), vbOKOnly, "Data Check")
Case "RAF"
If CustomerArray(z) = "RAF" Then
no_data = MsgBox("No categorized records for " & CustomerArray(z), vbOKOnly, "Data Check")
End If
Case "USAF"
If CustomerArray(z) = "USAF" Then
no_data = MsgBox("No categorized records for " & CustomerArray(z), vbOKOnly, "Data Check")
End If
Case "AMI"
If CustomerArray(z) = "AMI" Then
no_data = MsgBox("No categorized records for " & CustomerArray(z), vbOKOnly, "Data Check")
End If
End Select
End If
End If
next_analysis:
Next z
'======================================================================
' Adjusts the the cell formuls on the growth chart data sheets.
'======================================================================
Dim Date_Range As String
Dim MTBFinhnff As String
Dim MTBFinh As String
Dim MTBR As String
Dim TLF As Integer
TLF = 103 - TLA
DataArray = Array("All Customer Growth Chart Data", "RAF Growth Chart Data", _
"USAF Growth Chart Data", "AMI Growth Chart Data")
For SheetCount = 0 To UBound(DataArray)
Sheets(DataArray(SheetCount)).Select
Rows(TLE & ":53").Select
Range("A53").Activate
Selection.ClearContents
Rows(TLF & ":103").Select
Range("A103").Activate
Selection.ClearContents
MTBFinhnff = "=ROUND(H" & TLF - 1 & ",0)&"" Hrs"""
Range("C5").Formula = MTBFinhnff 'Actual MTBFinh+nff"
MTBFinh = "=ROUND(J" & TLF - 1 & ",0)&"" Hrs"""
Range("C6").Formula = MTBFinh 'Actual MTBFinh
Date_Range = "=""(""" & "&E5&""" & " to " & """ &E" & TLD & "&"")"""
Range("C3").Formula = Date_Range 'Date Range
MTBR = "=ROUND(E" & TLF - 1 & ",0)&"" Hrs"""
Range("C11").Formula = MTBR 'Actual MTBR
Next
'======================================================================
' Checks for type of data requested, MTBF and or MTBR.
' Deletes charts from workbook if necessary
'======================================================================
Sheets("FAR Removal Trend").Select
Application.DisplayAlerts = False
If Cells(2, 13) = 0 Then 'checks the MTBF request value 0 = no
Sheets("All Customer Growth Chart").Delete
Sheets("All Customer Growth Chart (2)").Delete
Sheets("RAF Customer Growth Chart").Delete
Sheets("RAF Customer Growth Chart (2)").Delete
Sheets("USAF Customer Growth Chart").Delete
Sheets("USAF Customer Growth Chart (2)").Delete
Sheets("AMI Customer Growth Chart").Delete
Sheets("AMI Customer Growth Chart (2)").Delete
End If
If Cells(2, 14) = 0 Then 'checks the MTBR request value 0 = no
Sheets("All Customer Growth Chart (2)").Delete
Sheets("All Customer Growth Chart (3)").Delete
Sheets("RAF Customer Growth Chart (2)").Delete
Sheets("RAF Customer Growth Chart (3)").Delete
Sheets("USAF Customer Growth Chart (2)").Delete
Sheets("USAF Customer Growth Chart (3)").Delete
Sheets("AMI Customer Growth Chart (2)").Delete
Sheets("AMI Customer Growth Chart (3)").Delete
End If
Application.DisplayAlerts = True
On Error Resume Next 'ignores warnings for deleted worksheets
Sheets("All Customer Growth Chart Data").Select
If Range("G" & TLF - 1) > 0 Then
Sheets("All Customer Growth Chart").Shapes("Caution Message").Visible = msoFalse
Sheets("All Customer Growth Chart (2)").Shapes("Caution Message").Visible = msoFalse
Sheets("All Customer Growth Chart (3)").Shapes("Caution Message").Visible = msoFalse
End If
Sheets("RAF Growth Chart Data").Select
If Range("G" & TLF - 1) > 0 Then
Sheets("RAF Customer Growth Chart").Shapes("Caution Message").Visible = msoFalse
Sheets("RAF Customer Growth Chart (2)").Shapes("Caution Message").Visible = msoFalse
Sheets("RAF Customer Growth Chart (3)").Shapes("Caution Message").Visible = msoFalse
End If
Sheets("USAF Growth Chart Data").Select
If Range("G" & TLF - 1) > 0 Then
Sheets("USAF Customer Growth Chart").Shapes("Caution Message").Visible = msoFalse
Sheets("USAF Customer Growth Chart (2)").Shapes("Caution Message").Visible = msoFalse
Sheets("USAF Customer Growth Chart (3)").Shapes("Caution Message").Visible = msoFalse
End If
Sheets("AMI Growth Chart Data").Select
If Range("G" & TLF - 1) > 0 Then
Sheets("AMI Customer Growth Chart").Shapes("Caution Message").Visible = msoFalse
Sheets("AMI Customer Growth Chart (2)").Shapes("Caution Message").Visible = msoFalse
Sheets("AMI Customer Growth Chart (3)").Shapes("Caution Message").Visible = msoFalse
End If
On Error GoTo Error_Handler 'resets error handling
'========================================================================
'automatically adjusts growth chart x-axis minimum scale value
'========================================================================
On Error Resume Next 'ignores select erros for sheets taht have been deleted
ChartArray = Array("All Customer Growth Chart", "All Customer Growth Chart (2)", _
"All Customer Growth Chart (3)", "RAF Customer Growth Chart", "RAF Customer Growth Chart (2)", _
"RAF Customer Growth Chart (3)", "USAF Customer Growth Chart", "USAF Customer Growth Chart (2)", _
"USAF Customer Growth Chart (3)", "AMI Customer Growth Chart", "AMI Customer Growth Chart (2)", _
"AMI Customer Growth Chart (3)")
DataArray = Array("All Customer Growth Chart Data", "RAF Growth Chart Data", _
"USAF Growth Chart Data", "AMI Growth Chart Data")
For SheetCount = 0 To UBound(ChartArray)
x = 1
Select Case SheetCount 'used to select correct data sheet
Case 0
y = 0
Case 3
y = 1
Case 6
y = 2
Case 9
y = 3
End Select
'deals with selecting sheets that have been deleted - prevents endless loop
If SheetCount = 0 And Sheets("FAR Removal Trend").Cells(2, 14) = -1 And _
Sheets("FAR Removal Trend").Cells(2, 13) = 0 Then
Sheets(ChartArray(2)).Select
ElseIf SheetCount = 3 And Sheets("FAR Removal Trend").Cells(2, 14) = -1 And _
Sheets("FAR Removal Trend").Cells(2, 13) = 0 Then
Sheets(ChartArray(5)).Select
ElseIf SheetCount = 6 And Sheets("FAR Removal Trend").Cells(2, 14) = -1 And _
Sheets("FAR Removal Trend").Cells(2, 13) = 0 Then
Sheets(ChartArray(8)).Select
ElseIf SheetCount = 9 And Sheets("FAR Removal Trend").Cells(2, 14) = -1 And _
Sheets("FAR Removal Trend").Cells(2, 13) = 0 Then
Sheets(ChartArray(11)).Select
Else
Sheets(ChartArray(SheetCount)).Select
End If
Do While x = 1
If ActiveChart.Axes(xlCategory).MinimumScale < Sheets(DataArray(y)).Range("F56") Then
'changes minimum scale by a positive factor of ten
ActiveChart.Axes(xlCategory).MinimumScale = ActiveChart.Axes(xlCategory).MinimumScale * 10
Else
'once minimum scale value has exceeded the first data point value, reduces
'minimum scale by a factor of ten
ActiveChart.Axes(xlCategory).MinimumScale = ActiveChart.Axes(xlCategory).MinimumScale / 10
x = 2 'used to exit loop
End If
Loop
Next
On Error GoTo Error_Handler 'resets error handling
'========================================================================
'checks to see if powerpoint was requested
'========================================================================
Sheets("FAR Removal Trend").Select
If Cells(2, 15) = -1 Then
Call ExcelCharts_to_Powerpoint
End If
'=======================================================================
'Cleans up the worksheets
'=======================================================================
cleanup:
On Error Resume Next
Application.DisplayAlerts = False
Select Case Sheets("FAR Removal Trend").Cells(2, 17) 'Customer ID
Case "RAF"
Sheets("All Customer Growth Chart").Delete
Sheets("All Customer Growth Chart (2)").Delete
Sheets("All Customer Growth Chart (3)").Delete
Sheets("All Customer Growth Chart Data").Delete
Sheets("Ratioed Trend Data").Delete
Sheets("USAF Customer Growth Chart").Delete
Sheets("USAF Customer Growth Chart (2)").Delete
Sheets("USAF Customer Growth Chart (3)").Delete
Sheets("USAF Growth Chart Data").Delete
Sheets("USAF Ratioed Trend Data").Delete
Sheets("AMI Customer Growth Chart").Delete
Sheets("AMI Customer Growth Chart (2)").Delete
Sheets("AMI Customer Growth Chart (3)").Delete
Sheets("AMI Growth Chart Data").Delete
Sheets("AMI Ratioed Trend Data").Delete
Case "USAF"
Sheets("All Customer Growth Chart").Delete
Sheets("All Customer Growth Chart (2)").Delete
Sheets("All Customer Growth Chart (3)").Delete
Sheets("All Customer Growth Chart Data").Delete
Sheets("Ratioed Trend Data").Delete
Sheets("RAF Customer Growth Chart").Delete
Sheets("RAF Customer Growth Chart (2)").Delete
Sheets("RAF Customer Growth Chart (3)").Delete
Sheets("RAF Growth Chart Data").Delete
Sheets("RAF Ratioed Trend Data").Delete
Sheets("AMI Customer Growth Chart").Delete
Sheets("AMI Customer Growth Chart (2)").Delete
Sheets("AMI Customer Growth Chart (3)").Delete
Sheets("AMI Growth Chart Data").Delete
Sheets("AMI Ratioed Trend Data").Delete
Case "AMI"
Sheets("All Customer Growth Chart").Delete
Sheets("All Customer Growth Chart (2)").Delete
Sheets("All Customer Growth Chart (3)").Delete
Sheets("All Customer Growth Chart Data").Delete
Sheets("Ratioed Trend Data").Delete
Sheets("RAF Customer Growth Chart").Delete
Sheets("RAF Customer Growth Chart (2)").Delete
Sheets("RAF Customer Growth Chart (3)").Delete
Sheets("RAF Growth Chart Data").Delete
Sheets("RAF Ratioed Trend Data").Delete
Sheets("USAF Customer Growth Chart").Delete
Sheets("USAF Customer Growth Chart (2)").Delete
Sheets("USAF Customer Growth Chart (3)").Delete
Sheets("USAF Growth Chart Data").Delete
Sheets("USAF Ratioed Trend Data").Delete
End Select
Application.DisplayAlerts = True
For x = Sheets.Count To 1 Step -1
On Error Resume Next
Sheets(x).Select
Range("A1").Select
ActiveChart.Deselect
Next
Exit_Procedure:
Application.CutCopyMode = False
Application.ScreenUpdating = True
Exit Sub
Error_Handler:
If Err.Number = 9 Then
MsgBox "An error has occurred in this application. " _
& vbCrLf & vbCrLf & "Please close all instances of Excel before running " _
& vbCrLf & "the requested trend chart.", _
Buttons:=vbCritical, Title:="DMT Error"
Application.DisplayAlerts = False
ActiveWindow.Close
Application.DisplayAlerts = True
Exit Sub
Else
MsgBox "An error has occurred in this application. " _
& "Please contact your technical support person and " _
& "tell them this information:" _
& vbCrLf & vbCrLf & "Error Number " & Err.Number & ", " _
& Err.Description, _
Buttons:=vbCritical, Title:="DMT Error"
Resume Exit_Procedure
Resume
End If
End Sub
Sub ExcelCharts_to_Powerpoint()
'This subroutine will convert the Excel sheets just created in twelve_month_trend_macro()
'to Powerpoint slides
'=============================================================================
Application.CutCopyMode = False
Application.ScreenUpdating = True
Dim SheetArray As Variant
Dim SheetCount As Integer
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim XLApp As Excel.Application
'Fills the array based on the MTBF/MTBR selection criteria
Sheets("FAR Removal Trend").Select
'MTBR only
If Cells(2, 13) = 0 Then
SheetArray = Array("All Customer Growth Chart (3)", _
"RAF Customer Growth Chart (3)", "USAF Customer Growth Chart (3)", _
"AMI Customer Growth Chart (3)")
End If
'MTBF only
If Cells(2, 14) = 0 Then
SheetArray = Array("All Customer Growth Chart", "RAF Customer Growth Chart", _
"USAF Customer Growth Chart", "AMI Customer Growth Chart")
End If
'MTBR and MTBF selected
If Cells(2, 14) = -1 Then
If Cells(2, 13) = -1 Then
SheetArray = Array("All Customer Growth Chart", "All Customer Growth Chart (2)", _
"All Customer Growth Chart (3)", "RAF Customer Growth Chart", "RAF Customer Growth Chart (2)", _
"RAF Customer Growth Chart (3)", "USAF Customer Growth Chart", "USAF Customer Growth Chart (2)", _
"USAF Customer Growth Chart (3)", "AMI Customer Growth Chart", "AMI Customer Growth Chart (2)", _
"AMI Customer Growth Chart (3)")
End If
End If
For SheetCount = 0 To UBound(SheetArray)
'Sets the formatting for import to PowerPoint
Sheets(SheetArray(SheetCount)).Select
'Open an instance of Powerpoint
If SheetCount = 0 Then
Set PPApp = CreateObject("Powerpoint.Application")
Set PPPres = PPApp.Presentations.Add
End If
Set PPSlide = PPPres.Slides.Add(SheetCount + 1, ppLayoutBlank)
' Applies the LMAERO template
PPPres.ApplyTemplate Filename:="\\MARNV005\Rms-C130J\Apps\APPS\EXCHANGE\RELIABILITY SHARE\LMAeroTemplate.pot"
PPApp.Visible = True
PPApp.ActivePresentation.Slides(SheetCount + 1).Select
'Change presentation to slide view
PPApp.ActiveWindow.ViewType = ppViewSlide
Sheets(SheetArray(SheetCount)).Select
Sheets(SheetArray(SheetCount)).ChartArea.Select
'Copy chart as a picture
ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, _
Format:=xlPicture
Set PPApp = GetObject(, "PowerPoint.Application")
PPSlide.Shapes.Paste.Select
' Align pasted chart
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
PPApp.ActiveWindow.Selection.ShapeRange.IncrementLeft -0.38
PPApp.ActiveWindow.Selection.ShapeRange.IncrementTop 23.62
Next SheetCount
End Sub