using the TransferSpreadsheet command

[presence76]

I am trying to take an Access table and export it to a spreadsheet that I am building with access. The code goes like this:

Function fcnRunBalancing()

BalanceDate = Forms![frmDailyBalancingOptions]![txtBalanceDate].Value
FileDate = FORMAT(BalanceDate, "YYYYMMDD")

Set xlapp = New excel.Application

xlapp.Visible = True
xlapp.Application.ScreenUpdating = False
xlapp.Application.DisplayAlerts = False

xlapp.Workbooks.Open "C:\Documents and Settings\jb83160\My Documents\my PI reports\testing\PI report" & ".xls"

xlapp.ActiveWorkbook.SaveAs filename:="C:\Documents and Settings\jb83160\My Documents\my PI reports\testing\529-" & FileDate & ".xls", _
FileFormat:=xlExcel9795, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel3, "tblPIfinal", "C:\Documents and Settings\jb83160\My Documents\my PI reports\testing\529-" & FileDate & ".xls"


xlapp.ActiveWorkbook.SaveAs filename:="C:\Documents and Settings\jb83160\My Documents\my PI reports\testing\529-" & FileDate & ".xls", _
FileFormat:=xlExcel9795, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
xlapp.ActiveWorkbook.Close
xlapp.Quit

First, I save an existing spreadsheet which I am using as a template. It has tabs named "PIfinal", "tracer" and "balancing". In this process, I am trying to take the PIfinal table that I have already created and load it ot the PIfinal tab of the spreadsheet. When I execute the transferspreadsheet command I get

Run-time error '3422'
cannot modify table structure
another user has the table open.

Any help would be greatly appreciated.

 

[presence76]

Here was my solution - I used SQL code instead of the TransferSpreadsheet command. The other difference is that I allowed the SQL code to create the spreadsheet for me instead of saving it from a template before I load it.

Code I used:

BalanceDate = Forms![frmDailyBalancingOptions]![txtBalanceDate].Value
FileDate = FORMAT(BalanceDate, "YYYYMMDD")

Dim strExcelFile As String
Dim strWorksheet As String
Dim strDB As String
Dim strTable As String
Dim objDB As Database

strExcelFile = "C:\Documents and Settings\jb83160\My Documents\my PI reports\testing\529-" & FileDate & ".xls"
strWorksheet = "pifinal"
strDB = "C:\Documents and Settings\jb83160\My Documents\my PI reports\testing\529autobalancedevelopment"
strTable = "pifinal"

Set objDB = OpenDatabase(strDB)


objDB.Execute _
"SELECT * INTO [Excel 8.0;DATABASE=" & strExcelFile & _
"].[" & strWorksheet & "] FROM " & "[" & strTable & "]"
objDB.Close
Set objDB = Nothing

 

[mdmilner]

Looks to me that your original problem is that you left the spreadsheet open. TransferSpreadsheet requires exclusive control of the xls.

Here are three methods that include explicitly opening the spreadsheet and would allow you to mostly use the beginning of your code as-is.

http://www.mvps.org/access/modules/mdl0035.htm

Another approach is this:

Use the FileCopy method to copy your template file to the destination location. Do not refer to the excel objects at all. Then use your transferspreadsheet method. I haven't included all my functions but it should be apparent by the naming what they probably do.

Function fcnRunBalancing() 

BalanceDate = Forms![frmDailyBalancingOptions]![txtBalanceDate].Value 
FileDate = FORMAT(BalanceDate, "YYYYMMDD") 

'FileCopy function here

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel3, "tblPIfinal", "C:\Documents and Settings\jb83160\My Documents\my PI reports\testing\529-" & FileDate & ".xls"

Here's a method I actually use:

Public Function ExportExcel(Optional blnFiles As Boolean)
Dim dbs As DAO.Database
Dim rs As DAO.Recordset
Dim rsf As DAO.Recordset
Dim qdf As DAO.QueryDef
Dim strSQL As String, strLocBase As String, strMyWhere As String
Dim strFLoc As String

Set dbs = CurrentDb

If blnFiles Then
  strSQL = "SELECT * FROM tblFiles"
Else
  strSQL = "SELECT * FROM tblmainfile"
End If
Set rs = dbs.OpenRecordset(strSQL, dbOpenSnapshot)
rs.Filter = "archiveMe = true"
Set rsf = rs.OpenRecordset()

With rsf
  Do Until rsf.EOF
    strFLoc = .Fields(2)
    ' This generates the save file location bypassing names in mainfile
    'strFLoc = FindDefaults("DefaultOpenLocation") & Right(!f_name, 4) & "\" & !f_name & ".xls"
    If ValidateLocations(strFLoc) <> 0 Then ' If exists, delete it first
        Call sDeleteTarget(strFLoc)
        Call sSleep(2500)
    End If
    Call sCopyTemplate(strFLoc)
    Call sSleep(2000)
    
    If ObjectExists("Query", "AutoExporting") Then
      DoCmd.DeleteObject acQuery, "AutoExporting"
    End If
    Select Case Left(!fmo, 2):
     Case "1/":
       strMyWhere = "WHERE [Date] LIKE '" & !fmo & "*' and [Date] Not Like '11/*/*'"
     Case Else:
       strMyWhere = "WHERE [Date] LIKE '" & !fmo & "*';"
    End Select
    Set qdf = dbs.CreateQueryDef("AutoExporting", GenerateSQL("AutoExporting", strMyWhere))
    Call ImportExport("AcExport", "AutoExporting", strFLoc)
    .MoveNext
  Loop
End With

Set rsf = Nothing
Set rs = Nothing
Set dbs = Nothing
End Function

Sub sCopyTemplate(ByVal strCopy As String)

strCopy = " /c copy " & FindDefaults("DefaultxlsLocation") & FindDefaults("DefaultxlsSheet") & " " & strCopy

Call Shell(Environ$("COMSPEC") & strCopy, vbNormalFocus)
DoEvents

End Sub

Sub sDeleteTarget(ByVal MyTarg As String)

MyTarg = " /c del " & MyTarg
'MyTarg = " /c del S:\AssignmentList\2002\Aug2002.xls"
Call Shell(Environ$("COMSPEC") & MyTarg, vbNormalFocus)
DoEvents

End Sub

Public Function ImportExport(ByVal Ltype As String, ByVal Tname As String, _
                                 ByVal TLoc As String) As Long
ErrorResume:
On Error GoTo Err_handler
Debug.Print Ltype & " File " & TLoc


Select Case Ltype:
    Case "acImport":  Ltype = 0
      'DoCmd.TransferSpreadsheet acImport, 8, Tname, TLoc, True, ""
    Case "acExport":  Ltype = 1
      'DoCmd.TransferSpreadsheet acExport, 8, Tname, TLoc, True, ""
    Case "acLink":    Ltype = 2
      'DoCmd.TransferSpreadsheet acLink, 8, Tname, TLoc, True, ""
End Select
DoCmd.TransferSpreadsheet " " & Ltype, 8, Tname, TLoc, True, ""
Exit Function

Err_handler:

 Select Case Err.Number:
  Case 2391:
    MsgBox Err.Number & " One or more fields in " & TLoc & " not in Database"
    Debug.Print TLoc & " Has too many fields"
    Call RemoveXLSColumns(TLoc)
    ' Need to use "old" routine that Links then runs SQL to append fields to tblData
  Case 3051:
    ' Somebody is in the table
  Case Else
    Debug.Print Err.Number & " " & Err.Description
 End Select
ImportExport = Err.Number
Err.Clear
End Function

Really the sDeleteTarget & sCopyTarget Functions were before I figured out how to use the FileSystemObject.

Deleting a file is as simple as:

Kill (path_to_file)

FileCopy(source_file, destination_file)

Mike