Help finding out problem.

[PeasNCarrots]

I run the following 2 subs seperately to create 2 different reports. After the 1st Sub has run the 2nd always breaks
right here with an out of range error.
'--------Fomat 1st Worksheet-----------
'Sort Col A
.Range("A3:I29").Select
.Range("A3:I30").Sort Key1:=Range("A3"),

But it is not out of range. All I do is reset the module and it runs fine. But I have to reset it everytime I run these reports. I can never get these subs running in succession without error, no matter what order I run them in.

I would buy you a nathan's hotdog if you can help. Thanks.






Option Compare Database

Sub sCopySendAgainFromRS()
'Transfer Records to Excel

Dim rs(1) As Recordset
Dim intMaxCol As Integer
Dim intMaxRow As Integer
Dim objXL As Excel.Application
Dim objWkb As Workbook
Dim objSht As Worksheet
Dim strReportDate As String



rowArray = Array(7, 11, 16, 24, 28, 29, 3)


Set rs(0) = CurrentDb.OpenRecordset("T_FINAL_DIV_REPORT", _
dbOpenSnapshot)
Set rs(1) = CurrentDb.OpenRecordset("T_SEND_AGAIN", dbOpenSnapshot)
strReportDate = DateAdd("d", -1, Date)

'Create New Excel App
Set objXL = New Excel.Application

For irs = 0 To 1
intMaxCol = rs(irs).Fields.Count

If rs(irs).RecordCount > 0 Then
rs(irs).MoveLast: rs(irs).MoveFirst
intMaxRow = rs(irs).RecordCount

With objXL
.Visible = True

If irs = 0 Then
Set objWkb = .Workbooks.Add
Set objSht = objWkb.Worksheets(1)
objWkb.Worksheets(3).Delete
objSht.Name = "Division Summary"
objSht.Activate
Else
Set objSht = objWkb.Worksheets(2)
objSht.Name = "Driver Detail"
objSht.Activate
End If

With objSht

ActiveWindow.DisplayGridlines = False
'Page Setup
With .PageSetup
.Orientation = xlLandscape
.LeftMargin = 25
.RightMargin = 25
.TopMargin = 5
.BottomMargin = 5
.CenterHorizontally = True
End With
'Add Field Names
For i = 0 To intMaxCol - 1
.Cells(3, i + 1) = rs(irs).Fields(i).Name
Next
'Copy Recordset to Cells
.Range(.Cells(4, 1), .Cells(intMaxRow, _
intMaxCol)).CopyFromRecordset rs(irs)

'Make sure all Values are correct format
.Range(.Cells(4, 16), .Cells(intMaxRow + 3, _
intMaxCol)).Select
For Each xCell In Selection
xCell.Value = xCell.Value
Next xCell

.Range("B2").Activate
.Range("A3:Z3").Font.Bold = True
.Range("A3:Z3").WrapText = True
.Columns("A:AZ").AutoFit


'Check to see what worksheet it is then format
If irs = 0 Then

'--------Fomat 1st Worksheet-----------
Set currentCell = .Range("A1")
'Sort Col A
.Range("A4").Sort _
Key1:=Worksheets("Division Summary").Columns("A"), _
Header:=xlGuess
'Delete Col A
currentCell.EntireColumn.Delete

'Add/Modify Borders
With .Range(.Cells(3, 1), .Cells(intMaxRow + 3, intMaxCol - 1))
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.BorderAround Weight:=xlThin
End With

For i = 0 To 6 'Array Param
'Create string for row selection
strRow = "A" & rowArray(i) & ":S" & rowArray(i)
.Range(strRow).Select

With Selection
'Change Borders for all Array parameter but 6
If i <> 6 Then
.Borders(xlInsideVertical).LineStyle = xlNone
.BorderAround Weight:=xlThin
.Font.Bold = True
Else
.Interior.Color = RGB(103, 204, 155)
End If

If i <> 5 And i <> 6 Then
.Interior.Color = RGB(192, 192, 192)
ElseIf i = 5 Then
.Interior.Color = RGB(255, 255, 153)
End If
End With
Next

'Center Data
.Range(.Cells(3, 2), .Cells(intMaxRow + 3, intMaxCol - 1)) _
.HorizontalAlignment = xlCenter

'Add Title
.Range("A1").Value = "Daily Send Again Report: " & strReportDate
.Range("A2").Value = "Division Summary"
.Range("A1:S1").Select
With Selection
.HorizontalAlignment = xlCenterAcrossSelection
.Font.Bold = True
.Font.Size = 14
End With
.Range("A2:S2").Select
With Selection
.HorizontalAlignment = xlCenterAcrossSelection
.Font.Bold = True
.Font.Color = RGB(0, 0, 255)
End With

'--------Now format 2nd Worksheet----------
ElseIf irs = 1 Then
Set currentCell = .Range("A1")
'Sort
.Range(.Cells(4, 1), .Cells(intMaxRow + 3, intMaxCol)).Sort _
Key1:=Worksheets("Driver Detail").Columns("A"), Order1:=xlAscending, _
Key2:=Worksheets("Driver Detail").Columns("R"), Order2:=xlDescending, _
Header:=xlGuess

'Center Data
.Range(.Cells(3, 5), .Cells(intMaxRow + 25, intMaxCol)) _
.HorizontalAlignment = xlCenter

'Add Subtotals
.Range(.Cells(3, 1), .Cells(intMaxRow + 3, intMaxCol)).Select
Selection.Subtotal GroupBy:=1, Function:=xlSum, _
TotalList:=Array(5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17)

'Add Title
.Range("A1").Value = "Daily Send Again Report: " & strReportDate
.Range("A2").Value = "Driver Detail"
.Range("A1:S1").Select
With Selection
.HorizontalAlignment = xlCenterAcrossSelection
.Font.Bold = True
.Font.Size = 14
End With
.Range("A2:S2").Select
With Selection
.HorizontalAlignment = xlCenterAcrossSelection
.Font.Bold = True
.Font.Color = RGB(0, 0, 255)
End With

'Color Header Cells
.Range("A3:S3").Select
With Selection
.Interior.Color = RGB(103, 204, 155)
End With

'Add Formula to Subtotal Level 3
ActiveSheet.Outline.ShowLevels RowLevels:=3
.Range("R4").Select
ActiveCell.FormulaR1C1 = "=RC[-12]/RC[-13]"
.Range("R4").Select
Selection.AutoFill Destination:=Range(.Cells(4, 18), .Cells(intMaxRow + 25, 18)), Type:=xlFillDefault

.Range("S4").Select
ActiveCell.FormulaR1C1 = "=RC[-14]/RC[-13]"
.Range("S4").Select
Selection.AutoFill Destination:=Range(.Cells(4, 19), .Cells(intMaxRow + 25, 19)), Type:=xlFillDefault


'Format
Range(.Cells(4, 19), .Cells(intMaxRow + 24, 19)).Select
Selection.NumberFormat = "0.00"
End If
End With
End With
End If

Next irs

sFilename = Format(DateAdd("d", -1, Date), "mmddyy")
objSht.SaveAs (sFilename)
objXL.Quit

'Zip File and send to FTP Site
winZipit """D:\Documents and Settings\BOS1PER\My Documents\" & sFilename & ".xls""", _
"""G:\NER\E_NewEngland\IndEng\OE\Reports\Send Agains\Service Exceptions\" & sFilename & """", True

'Clear Variables
Set rs(0) = Nothing
Set rs(1) = Nothing
Set objXL = Nothing
Set objWkb = Nothing
Set objSht = Nothing
End Sub


Sub sCopyNoSuchFromRS()

Dim rs(1) As Recordset
Dim intMaxCol As Integer
Dim intMaxRow As Integer
Dim objXL As Excel.Application
Dim objWkb As Workbook
Dim objSht As Worksheet
Dim strReportDate As String



rowArray = Array(7, 11, 16, 24, 28, 29, 3)


Set rs(0) = CurrentDb.OpenRecordset("T_FINAL_NO_SUCH_NUMBER", _
dbOpenSnapshot)
Set rs(1) = CurrentDb.OpenRecordset("sQ_NO_SUCH_SUMMARY_SLIC", dbOpenSnapshot)
strReportDate = DateAdd("d", -1, Date)

'Create New Excel App
Set objXL = New Excel.Application

For irs = 0 To 1
intMaxCol = rs(irs).Fields.Count

If rs(irs).RecordCount > 0 Then
rs(irs).MoveLast: rs(irs).MoveFirst
intMaxRow = rs(irs).RecordCount

With objXL
.Visible = True
If irs = 0 Then
Set objWkb = .Workbooks.Add
Set objSht = objWkb.Worksheets(1)
objSht.Name = "Division Summary"
objSht.Activate
.Windows(1).DisplayGridlines = False

Else

Set objSht = objWkb.Worksheets(2)
objSht.Name = "Driver Detail"
objSht.Activate
.Windows(1).DisplayGridlines = False
End If

With objSht

'Page Setup
With .PageSetup
.Orientation = xlLandscape
.LeftMargin = 25
.RightMargin = 25
.TopMargin = 5
.BottomMargin = 5
.CenterHorizontally = True
End With
'Add Field Names
For i = 0 To intMaxCol - 1
.Cells(3, i + 1) = rs(irs).Fields(i).Name
Next
'Copy Recordset to Cells
.Range(.Cells(4, 1), .Cells(intMaxRow, _
intMaxCol)).CopyFromRecordset rs(irs)

.Range("B2").Activate
.Range("A3:Z3").Font.Bold = True
.Range("A3:Z3").WrapText = True
.Columns("A:AZ").AutoFit


'Check to see what worksheet it is then format
If irs = 0 Then

'--------Fomat 1st Worksheet-----------
'Sort Col A
.Range("A3:I29").Select
.Range("A3:I30").Sort Key1:=Range("A3"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

'Delete Col A
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
' currentCell.EntireColumn.Delete

'Add/Modify Borders
With .Range(.Cells(3, 1), .Cells(intMaxRow + 3, intMaxCol - 1))
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.BorderAround Weight:=xlThin
End With

For i = 0 To 6 'Array Param
'Create string for row selection
strRow = "A" & rowArray(i) & ":H" & rowArray(i)
.Range(strRow).Select

With Selection
'Change Borders for all Array parameter but 6
If i <> 6 Then
.Borders(xlInsideVertical).LineStyle = xlNone
.BorderAround Weight:=xlThin
.Font.Bold = True
Else
.Interior.Color = RGB(103, 204, 155)
End If

If i <> 5 And i <> 6 Then
.Interior.Color = RGB(192, 192, 192)
ElseIf i = 5 Then
.Interior.Color = RGB(255, 255, 153)
End If
End With
Next

'Center Data
.Range(.Cells(3, 2), .Cells(intMaxRow + 3, intMaxCol - 1)) _
.HorizontalAlignment = xlCenter

'Add Title
.Range("A1").Value = "No Such Number Report: " & strReportDate
.Range("A2").Value = "Division Summary"
.Range("A1:H1").Select
With Selection
.HorizontalAlignment = xlCenterAcrossSelection
.Font.Bold = True
.Font.Size = 14
End With
.Range("A2:H2").Select
With Selection
.HorizontalAlignment = xlCenterAcrossSelection
.Font.Bold = True
.Font.Color = RGB(0, 0, 255)
End With

'--------Now format 2nd Worksheet----------
ElseIf irs = 1 Then
Set currentCell = .Range("A1")
'Sort
.Range("A4").Select
.Range(.Cells(4, 1), .Cells(intMaxRow + 3, intMaxCol)).Sort _
Key1:=Worksheets("Driver Detail").Columns("A"), Order1:=xlAscending, _
Key2:=Worksheets("Driver Detail").Columns("K"), Order2:=xlDescending, _
Header:=xlGuess

'Center Data
.Range(.Cells(3, 5), .Cells(intMaxRow + 25, intMaxCol)) _
.HorizontalAlignment = xlCenter

'Add Subtotals
.Range(.Cells(3, 1), .Cells(intMaxRow + 3, intMaxCol)).Select
Selection.Subtotal GroupBy:=1, Function:=xlSum, _
TotalList:=Array(5, 6, 7, 8, 9, 10)

'Add Title
.Range("A1").Value = "No Such Number Report: " & strReportDate
.Range("A2").Value = "Driver Detail"
.Range("A1:K1").Select
With Selection
.HorizontalAlignment = xlCenterAcrossSelection
.Font.Bold = True
.Font.Size = 14
End With
.Range("A2:K2").Select
With Selection
.HorizontalAlignment = xlCenterAcrossSelection
.Font.Bold = True
.Font.Color = RGB(0, 0, 255)
End With

'Color Header Cells
.Range("A3:K3").Select
With Selection
.Interior.Color = RGB(103, 204, 155)
End With

End If
End With
End With
End If

Next irs

sFilename = Format(DateAdd("d", -1, Date), "mmddyy") & "_NoSuchNumber"
objSht.SaveAs (sFilename)
objXL.Quit



winZipit """D:\Documents and Settings\BOS1PER\My Documents\" & sFilename & ".xls""", _
"""G:\NER\E_NewEngland\IndEng\OE\Reports\No Such Number\" & sFilename & """", True

'Clear Variables
Set rs(0) = Nothing
Set rs(1) = Nothing
Set objXL = Nothing
Set objWkb = Nothing
Set objSht = Nothing


End Sub

 

[PHV]

Yet another implicit Excel.Application instantiation syndrom.
Replace this:
ActiveWindow.DisplayGridlines = False
By this:
objXL.ActiveWindow.DisplayGridlines = False
and so forth in your code.
Examples of line with problem:
For Each xCell In Selection
Sort Key1:=Range("A3"),
...

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ222-2244

 

[cLFlaVA]

Have you tried removing or commenting out the line:

[tt].Range("A3:I29").Select[/tt]

Selecting ranges in VBA leads to slower functionality and undesired errors (are any errors desired?)


?

*cLFlaVA
----------------------------
A pirate walks into a bar with a huge ship's steering wheel down his pants.
The bartender asks, "Are you aware that you have a steering wheel down your pants?"
The pirate replies, "Arrrrr! It's driving me nuts!

 

[PeasNCarrots]

PHV,

What do I change the line
For Each xCell In Selection
to?

It now breaks there once I corrected the ActiveWindow portion of it.

This is my first time programming using the excel library.

 

[PHV]

Have you tried this ?
For Each xCell In objXL.Selection

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ222-2244

 

[PeasNCarrots]

PHV,

Thanks, it seems to be working fine now. I am now that much smarter because of you. I can mail u a nathan hotdog, the best in the world.