Help handling errors associated multiple instances of Excel

jslomka

New Member
Joined
Sep 20, 2006
Messages
22
I'm using Excel 2003 SP2 & Access SP2 on a Windows XP machine.
Our problem is when a user has an instance of Excel open prior to running our process we get error 9 "Subscript out of range" when the code tries to move the "FAR Removal Trend.xls" sheet to our template. Our process is as follows, we send the data from Access using a DoCmd.OutputTo method (the first set of code). We then open the template and the code in the template (second set of code) moves the "FAR Removal Trend.xls" worksheet into the template were we then process the data. Everthing works fine when there are no instances of Excel open prior to starting the process. However when an instance of Excel is already open the "FAR Removal Trend.xls" is opened in one instance and the template is opened in another instance. The code in the template can not see the "FAR Removal Trend.xls" workbook and sets error 9. I have been trying to figure out if I can use API (FindWindowEx in the user32 lib) to resolve this issue. No luck so far. Any help would be greatly appreciated.

Code:
Private Sub Trend_Curve_Click()

Dim xlApp As Object
Dim strDefaultDir As String
Set xlApp = CreateObject("Excel.Application")
strDefaultDir = Application.GetOption("Default Database Directory")
strDefaultDir = strDefaultDir & "\FAR Removal Trend.xls"
On Error Resume Next
Kill (strDefaultDir)
On Error GoTo Error_Handler
If MTBF_PLOT = 0 And MTBR_PLOT = 0 Then
    MsgBox "Type of plot not selected, please select MTBF and/or MTBR plot.", vbCritical, "Error"
Else
    DoCmd.OutputTo acQuery, "FAR Removal Trend", "MicrosoftExcel03(*.xls)", "", True, ""
 
    Set xlApp = GetObject(, "Excel.Application")
    xlApp.Visible = True
    xlApp.Workbooks.Add Template:= _
    "\\MARNV005\Rms-C130J\Apps\APPS\FRACAS\Templates\060927_Universal Trend Template.xlt"
    xlApp.Run "'060927_Universal Trend Template1'!Universal_Trend.Universal_Trend"
    
 End If
 
Exit_Procedure:
    Exit Sub

Error_Handler:
    If Err.Number = 2501 Or 440 Then
        Resume Exit_Procedure
    ElseIf Err.Number = 2302 Then
    MsgBox "An error has occurred in this application. " _
        & vbCrLf & vbCrLf & "Please close the Excel file before running the " _
        & vbCrLf & "requested trend chart.", _
        Buttons:=vbCritical, TITLE:="DMT Error"
    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
    Error [(errornumber)]
End Sub

Code:
'===============================================
'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")

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
 

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
76,300
Office Version
  1. 365
Platform
  1. Windows
Where are you actually getting the error?

Since you seem to be already automating Excel why not use that instance to do whatever it is you are doing?
 

jslomka

New Member
Joined
Sep 20, 2006
Messages
22
The error occurs at line

Windows("FAR Removal Trend.xls").Activate

in the second set of code.

There are 2 process involved, 1) Access outputing the data selected by the user, can not add automation to the output command file, just a workbook output 2) open the template which contains the automation, sometimes in a second instance of Excel.
 

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
76,300
Office Version
  1. 365
Platform
  1. Windows
Sorry I don't quite understand.:)

Why can't you just do everything in Access?
 

jslomka

New Member
Joined
Sep 20, 2006
Messages
22

ADVERTISEMENT

Access can not do everything we are doing in Excel. I did not include all of the code in the initial post. The attached code is the complete program. I think you will understand why I can not do everything in Access. Thanks for the quick response.

Code:
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
 

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
76,300
Office Version
  1. 365
Platform
  1. Windows
What I was actually suggesting was since you are already automating Excel from Access VBA (well I think you are anyway) then just do everything from there.

Where exactly are the 2 sets of code located?

I assume Trend_Curve_Click is in Access and Universal_Trend in Excel?

PS I just noticed you're automating PowerPoint from Excel in the sub ExcelCharts_to_Powerpoint.
 

jslomka

New Member
Joined
Sep 20, 2006
Messages
22

ADVERTISEMENT

Yes I am automating Excel from Access and Powerpoint from Excel. Trend_Curve_Click is in Access and Universal_Trend is in Excel. I do not understand how I could do everything from Access. I believe I could still end up with multiple instance of Excel and still get the "Subscript out of range" error, wouldn't I? Please note, I have only been programming for about a year and have learned most of my advance techniques from the VBA and Macros for Microsoft Excel book. I may be missing something simple here. Once again thanks for the help.
 

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
76,300
Office Version
  1. 365
Platform
  1. Windows
In the first piece of code you have an instance of Excel, xlApp.

You therefore have total control over that and can manipulate it to your heart's content.

In fact you've already done a little of that here.
Code:
xlApp.Workbooks.Add Template:= _    "\\MARNV005\Rms-C130J\Apps\APPS\FRACAS\Templates\060927_Universal Trend Template.xlt"

PS Why are you using both GetObject and CreateObject?

GetObject will grab an existing instance of Excel whereas CreateObject will create a new one.

You really should only need one or the other.
 

jslomka

New Member
Joined
Sep 20, 2006
Messages
22
The Createobject is needed when an instance of Excel does not exist. I tried using the the GetObject to open the template in the same instance of Excel that contains the exported data. Do you think I could set on error resume next, use a GetObject if an error occurs then use a CreateObject to set up the instance of Excel to export the data to? I'm not sure what would happen if a user already has several instances of Excel already open.
 

Forum statistics

Threads
1,137,340
Messages
5,680,916
Members
419,945
Latest member
Carrie Sellers

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top