heron_rider
New member
- Local time
- Today, 10:11
- Joined
- May 31, 2011
- Messages
- 2
Hello Forum,
I am getting Run Time Error 9: Subscript out of range in an Access VBA project I am working on. The project is designed to write data (or a message saying there is no data) from query results to 6 tabs in a preformatted Excel file. The 6 tabs correspond to 6 different categories of of the entity I am covering. The code seems to work on the first time through (1st category/1st tab) and also on the 2nd time through (open the recordset, opens the Excel file, writes the data to the cells)then refuses to save the file.
I have checked spellings. From the searching I have done, I think it is a problem with what workbook is active. I have tried multiple methods all to no avail.
The offending line is:
'*****the next line crashes on 2nd time through****************
Workbooks("C:\UCMR3\2003 Draft SMP Master Template John.xls").Save
Here is the code (this is my 1st post, not sure what the code posting ettiquette, please forgive any faux pas)
I am getting Run Time Error 9: Subscript out of range in an Access VBA project I am working on. The project is designed to write data (or a message saying there is no data) from query results to 6 tabs in a preformatted Excel file. The 6 tabs correspond to 6 different categories of of the entity I am covering. The code seems to work on the first time through (1st category/1st tab) and also on the 2nd time through (open the recordset, opens the Excel file, writes the data to the cells)then refuses to save the file.
I have checked spellings. From the searching I have done, I think it is a problem with what workbook is active. I have tried multiple methods all to no avail.
The offending line is:
'*****the next line crashes on 2nd time through****************
Workbooks("C:\UCMR3\2003 Draft SMP Master Template John.xls").Save
Here is the code (this is my 1st post, not sure what the code posting ettiquette, please forgive any faux pas)
PHP:
Option Compare Database
Option Explicit
'sub will gather records by stepping through 2 lookup tables and export to Excel
Public Sub MakeSMP()
Dim db As Database
Dim strPrCall As String
Dim strReCall As String
Dim strState As String
Dim strSource As String
Dim strSize As String
Dim rstDataPr As dao.Recordset
Dim rstDataRe As dao.Recordset
Dim rs1 As adodb.Recordset 'use this for state look up
Dim rs2 As adodb.Recordset 'use this for size/source look up
Dim xlsObject As Object
Dim PWS As String
Dim lngRow As Long
Dim intCol As Integer
Dim strCell As String
Dim intI As Integer
Dim strTest As String
Dim intPCount As Integer
Dim strCat 'combine size and source into a category
Dim Destwb As Workbook 'Draft SMP file
Dim strFileName As String 'to construct draft SMP file name
Dim strPath As String ' this is where the draft SMP are saved S:\UCMR\UCMR3\SMPs\L1 Draft SMP data
Dim qrydefPr As dao.QueryDef
Set db = CurrentDb()
Set rs1 = New adodb.Recordset
rs1.Open "tblStateLookUp", CurrentProject.Connection, adOpenKeyset, adLockOptimistic, adCmdTableDirect
Set rs2 = New adodb.Recordset
rs2.Open "tblSizeSourceLookUp", CurrentProject.Connection, adOpenKeyset, adLockOptimistic, adCmdTableDirect
rs1.MoveFirst
strState = rs1![State]
rs2.MoveFirst
strSource = rs2![Source]
strSize = rs2![Size]
strCat = strSource & strSize
MsgBox "Category is " & strCat
Do 'This is the Size/Source Loop
'Next 5 lines calls the query for the primary systems
Set qrydefPr = db.QueryDefs("qryL1PrimarySelectSMPDataCalled")
qrydefPr.Parameters!State = strState
qrydefPr.Parameters!PWSSize = strSize
qrydefPr.Parameters!PWSSource = strSource
Set rstDataPr = qrydefPr.OpenRecordset(dbOpenDynaset)
If Not (rstDataPr.BOF And rstDataPr.EOF) Then 'There are no records if Beginning-Of-File and End-Of-File are both true.
rstDataPr.MoveLast
intPCount = rstDataPr.RecordCount
MsgBox "There are " & intPCount & " records for this category"
Set xlsObject = New Excel.Application
xlsObject.Workbooks.Open FileName:="C:\UCMR3\2003 Draft SMP Master Template John.xls" 'Formatted
'xlsObject.Workbooks.Open FileName:="S:\UCMR\UCMR3\SMPs\Draft SMP Master Template John.xlsx" 'Formatted
'xlsObject.Workbooks.Open Filename:="S:\UCMR\UCMR3\SMPs\Draft SMP Master Template Unformatted.xlsx" 'UnFormatted
xlsObject.Visible = True
lngRow = 5
rstDataPr.MoveFirst
Do Until rstDataPr.EOF 'This loop writes one or more SMP records
PWS = strCat
'This selects the worksheet in the workbook you want to add data to
Select Case PWS
Case "GWVS"
xlsObject.Sheets("Very Small GW").Select
Case "GWS"
xlsObject.Sheets("Small GW").Select
Case "GWM"
xlsObject.Sheets("Medium GW").Select
Case "SWVS"
xlsObject.Sheets("Very Small SW").Select
Case "SWS"
xlsObject.Sheets("Small SW").Select
Case "SWM"
xlsObject.Sheets("Medium SW").Select
End Select
With xlsObject
For intCol = 2 To 15
intI = intCol - 2
With .ActiveSheet.Cells(lngRow, intCol)
.Font.Name = "Arial Black"
.Font.Size = 10
.Value = rstDataPr(intI)
End With
Next intCol
'Workbooks("C:\UCMR3\2003 Draft SMP Master Template John.xls").Activate
'*****the next line crashes on 2nd time through****************
Workbooks("C:\UCMR3\2003 Draft SMP Master Template John.xls").Save
lngRow = lngRow + 1
'Workbooks("Draft SMP Master Template John.xlsx").Save
MsgBox "Woohooo The code got here"
xlsObject.Quit
Set xlsObject = Nothing
rstDataPr.MoveNext
If rstDataPr.EOF = True Then
'MsgBox ActiveWorkbook.Name
Exit Do
End If
End With
Loop 'End of do to write records
If rs2.EOF = True Then
Exit Do
Else
rs2.MoveNext
strSource = rs2![Source]
strSize = rs2![Size]
strCat = strSource & strSize
MsgBox "Category is " & strCat & " " & "Moving From the one or more records loop"
End If
rstDataPr.Close
Set rstDataPr = Nothing
Else
MsgBox "There are " & 0 & " records for this category"
Set xlsObject = New Excel.Application
xlsObject.Workbooks.Open FileName:="C:\UCMR3\2003 Draft SMP Master Template John.xls" 'Formatted
'xlsObject.Workbooks.Open FileName:="S:\UCMR\UCMR3\SMPs\Draft SMP Master Template John.xlsx" 'Formatted
'xlsObject.Workbooks.Open Filename:="S:\UCMR\UCMR3\SMPs\Draft SMP Master Template Unformatted.xls" 'UnFormatted
xlsObject.Visible = True
lngRow = 5
PWS = strCat
'This selects the worksheet in the workbook you want to add data to
Select Case PWS
Case "GWVS"
xlsObject.Sheets("Very Small GW").Select
Case "GWS"
xlsObject.Sheets("Small GW").Select
Case "GWM"
xlsObject.Sheets("Medium GW").Select
Case "SWVS"
xlsObject.Sheets("Very Small SW").Select
Case "SWS"
xlsObject.Sheets("Small SW").Select
Case "SWM"
xlsObject.Sheets("Medium SW").Select
End Select
With xlsObject
For intCol = 2 To 2
intI = intCol - 2
With .ActiveSheet.Cells(lngRow, intCol)
.HorizontalAlignment = xlLeft
.Font.Name = "Arial Black"
.Font.Size = 16
End With
.ActiveCell.Value = "There are no systems in this category"
MsgBox ActiveWorkbook.Name
Workbooks("2003 Draft SMP Master Template John.xls").Save
xlsObject.Quit
Set xlsObject = Nothing
Next intCol
End With
If rs2.EOF = True Then
Exit Do
Else
rs2.MoveNext
strSource = rs2![Source]
strSize = rs2![Size]
strCat = strSource & strSize
MsgBox "Category is " & strCat & " " & "Moving From the zero records loop"
End If
rstDataPr.Close
Set rstDataPr = Nothing
End If
Loop Until rs2.EOF 'This is the end of the Size/Source Do
strFileName = rs1.[State] & "Draft SMP"
strPath = "S:\UCMR\UCMR3\SMPs\L1 Draft SMP data"
With Destwb
.SaveAs strPath & strFileName & ".xlsx"
End With
End Sub