Added sheet in excel from Access not working properly

[jadixon]

I have a program in access that creates an excel file from data out of my access database. In some cases, I want to add a sheet to the current file instead of creating a new file. I can add the sheet fine, but I cannot get the sheet to move to the end of the list, nor can I get it to actually write the data to the new sheet: it always writes to the first one.

I am using late binding (not sure if that is causing a problem or not).

Any ideas or helpful hints are welcome!

Here is my code:

Set appExcel = CreateObject("Excel.Application")
appExcel.Visible = False

'start looping through the sub assembly list
strsql = "Select RecId, Part_Number, SubAsm from All_Project_SubAsm"
If Len(strCriteria) > 0 Then
'add in the code criteria
strsql = strsql & " and " & strCriteria
End If
strsql = strsql & " order by part_number"
Set rsProject = db.OpenRecordset(strsql, dbOpenDynaset, dbSeeChanges)
If rsProject.RecordCount <= 0 Then
MsgBox "Error retrieving subassemblies for this project; process terminating!"
Exit Function
End If
strTemplate = "p:\ccrs\ESDPTLST.xls"
Set newbook = appExcel.Workbooks.Open(strTemplate)

rsProject.FindFirst "mid$(Part_Number,1,3) = '" & strProject & "'"
If Not rsProject.NoMatch Then
'rsProject.MoveFirst
intPos = InStr(rsProject!Part_Number, "-")
strBase = Mid$(rsProject!Part_Number, 1, intPos - 1)
intSheet = 1
Do

appExcel.worksheets(intSheet).Activate
appExcel.worksheets(intSheet).Select
If intSheet > 1 Then _
appExcel.worksheets(intSheet).Move After:=(appExcel.worksheets(intSheet - 1))
strsql = "Select * from SubAsm_Report_Query where recid = " & rsProject!RecID & " order by [16C], [16b]"
Set rsrec = db.OpenRecordset(strsql, dbOpenDynaset, dbSeeChanges)
If rsrec.RecordCount <= 0 Then
MsgBox "There is an error with this part!"
Exit Function
End If
rsrec.MoveFirst
If rsrec![16K] = True Then 'esd
appExcel.ActiveSheet.Shapes("Picture 3").Visible = True
Else
appExcel.ActiveSheet.Shapes("Picture 3").Visible = False
End If
'build the new file name
strfile = rsrec![15H]
If InStr(strfile, "-") > 0 Then
intPos = InStr(strfile, "-")
strfile = Mid$(strfile, 1, intPos - 1)
End If
strfile = strfile & "pl"
If Len(rsrec![15K]) > 0 Then _
strfile = strfile & rsrec![15K]
appExcel.ActiveSheet.Cells(5, 1) = appExcel.ActiveSheet.Cells(5, 1) & " " & rsrec![15E]
appExcel.ActiveSheet.Cells(6, 1) = appExcel.ActiveSheet.Cells(6, 1) & " " & rsrec![15F]
appExcel.ActiveSheet.Cells(7, 1) = appExcel.ActiveSheet.Cells(7, 1) & " " & rsrec![15G]
appExcel.ActiveSheet.Cells(9, 1) = appExcel.ActiveSheet.Cells(9, 1) & " " & rsrec![15H]
appExcel.ActiveSheet.Cells(5, 8) = appExcel.ActiveSheet.Cells(5, 8) & " " & rsrec![15L]
appExcel.ActiveSheet.Cells(6, 8) = appExcel.ActiveSheet.Cells(6, 8) & " " & rsrec![15D]
appExcel.ActiveSheet.Cells(7, 8) = appExcel.ActiveSheet.Cells(7, 8) & " " & rsrec![15K]
appExcel.ActiveSheet.Cells(8, 8) = appExcel.ActiveSheet.Cells(8, 8) & " " & rsrec![15J]
intRow = 14
'headers are now done, so start filling in the data
Do
appExcel.ActiveSheet.Cells(intRow, 1) = rsrec![16C]
If rsrec![16D] = 0 Then
appExcel.ActiveSheet.Cells(intRow, 2) = "AR"
Else
appExcel.ActiveSheet.Cells(intRow, 2) = rsrec![16D]
End If
appExcel.ActiveSheet.Cells(intRow, 3) = rsrec![16E]
appExcel.ActiveSheet.Cells(intRow, 4) = rsrec![16F]
appExcel.ActiveSheet.Cells(intRow, 5) = rsrec![16G]
appExcel.ActiveSheet.Cells(intRow, 6) = rsrec![16H]
appExcel.ActiveSheet.Cells(intRow, 7) = rsrec![16I]
appExcel.ActiveSheet.Cells(intRow, 8) = rsrec![16J]
appExcel.ActiveSheet.Cells(intRow, 9) = rsrec![16K]
appExcel.ActiveSheet.Cells(intRow, 10) = rsrec![16L]
rsrec.MoveNext
intRow = intRow + 1
Loop Until rsrec.EOF
rsrec.Close
rsProject.FindNext "mid$(Part_Number,1,3) = '" & strProject & "'"
If Not rsProject.NoMatch Then
intPos = InStr(rsProject!Part_Number, "-")
If strBase = Mid$(rsProject!Part_Number, 1, intPos - 1) Then
'new sheet not new file
appExcel.Sheets.Add
intSheet = intSheet + 1
Else
strBase = Mid$(rsProject!Part_Number, 1, intPos - 1)
newbook.SaveAs "c:\ccrs_output\" & strfile & ".xls"
Set newbook = appExcel.Workbooks.Open(strTemplate)
intSheet = 1
End If
Else
newbook.SaveAs "c:\ccrs_output\" & strfile & ".xls"
End If
Loop Until rsProject.NoMatch
End If
rsProject.Close
appExcel.Quit
Set appExcel = Nothing

 

[ck1999]

Have you stepped through the code?

also these statements (2 different locations)

newbook.SaveAs "c:\ccrs_output\" & strfile & ".xls"

newbook.SaveAs "c:\ccrs_output\" & strfile & ".xls"

does not have newbook defined yet

to fix this issue rearrange you code to this

        If intSheet > 1 Then _
            appExcel.worksheets(1).Move After:=(appExcel.worksheets(intSheet - 1))
appExcel.worksheets(intSheet).Activate
        appExcel.worksheets(intSheet).Select

        strsql = "Select * from SubAsm_Report_Query where recid = " & rsProject!RecID & " order by [16C], [16b]"

see if this works

Ck1999

 

[ck1999]

also replace this

intSheet - 1

with

intSheet


ck1999

 

[jadixon]

Actually I have found that for some reason the activate and move statements do not appear to work with an integer. I changed the variable to be a string and forced "Sheet2" into it and it worked. So I have changed my code to create a string with the correct sheet number concatenated to it.

I now need to figure out how to get the page formatting and such from the first sheet to the others, but that will be another question.

Thanks for the help!

 

[ck1999]

the activate and move DO work with an integer. However the sheet number changes depening on your order.

So when you add a sheet the new sheet is sheet #1 (not in name but the integer reference). (1st tab) then when you move it to the end of your sheet tabs. It is no longer sheet #1 but sheet intsheet.

That is why I moved your reference to sheetnames below your move statement.

In reference to your last statement. Why not copy sheet1 instead of adding a sheet and then clear the sheet of all values. This way all your formatting will be the same on all the new sheets.

ck1999

 

[jadixon]

What is the correct format of the copy statement? I have been having trouble getting the formatting to go with the copy.

 

[ck1999]

Try this

if intSheet > 2 then
Sheets(1).Copy after:=Sheets(intSheet-1)
elseif intsheet = 2 then
Sheets(1).Copy after:=Sheets(1)
end if
Sheets(intsheet).Select
Range("A1", "Z600").ClearContents

This is to replace

If intSheet > 1 Then _
appExcel.worksheets(intSheet).Move After:=(appExcel.worksheets(intSheet - 1))

Then delete
appExcel.Sheets.Add

ck1999

 

[jadixon]

Go it! Thanks!