Export 03 Access Query to Excel 07

[Fattire]

I find it hard to believe that this doesn't work in A03, is it true a03 will not do a transfer spreadsheet to excel 07? I usally can't find the little secrets around this site so I'm asking here.

Option Compare Database

Private Sub cmd_XFER_2007_Click()

    Call XFERExcel2007
    
End Sub


Function XFERExcel2007()
On Error GoTo XFERExcel2007_Err

DoCmd.SetWarnings False
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "QRY_OUTPUT", "C:\SATS.xlsx", -1
DoCmd.SetWarnings True

XFERExcel2007_Exit:
Exit Function

XFERExcel2007_Err:
MsgBox Error$
Resume XFERExcel2007_Exit

End Function

Any help would be appreciated.

 

[Fattire]

The objectieve of course is to export more than 65K lines, preferably 600K.

 

[PHV]

AC2003 doesn't know XL2007 and thus I'm pretty sure it'll refuse to transfer more than 64K lines to excel ...

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[Fattire]

I hope they come out with a simple service pack or hotfix for it - Most of us use '03 still. I guess Access 2007 didn't even have this functionality until SP2 came out. Rediculous.

 

[PWise]

try opening the query as a recordset
and excell as an object and useing the copyfromrecordset method

 

[Fattire]

Thank you PWise, not as easy as before but it works, this exported 631K rows in 15 seconds into Excel 2007 from Access 2003: I had to do the object as CreateObject("Excel.Application.12"), I had never thought of using a version number in there before.

Private Sub cmd_Dish2_Click()

    Call XFER_EXCEL_2007_V2

End Sub

Function XFER_EXCEL_2007_V2()

    Dim rec1 As DAO.Recordset
    Dim con1 As DAO.Database
    Dim sqlstr As String
    
    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Set xlApp = CreateObject("Excel.Application.12")
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.Worksheets(1)
    Dim objRec As Recordset
    Dim strSheetName As String
    Dim qryName As String
           
    xlApp.Visible = True
    
    qryName = "QRY_OUTPUT"
    
    sqlstr = "SELECT * FROM " & qryName
    Set con1 = CurrentDb()
    Set rec1 = con1.OpenRecordset(sqlstr)
    Set objRST = Application.CurrentDb.OpenRecordset(sqlstr)

    strSheetName = qryName

    Set xlSheet = xlBook.Sheets(1)
    For lvlColumn = 0 To objRST.Fields.Count - 1
    xlSheet.Cells(1, lvlColumn + 1).Value = objRST.Fields(lvlColumn).Name
    Next

    With xlSheet.Range("A2").Select
         xlApp.ActiveWindow.FreezePanes = True
    End With

    xlSheet.Range(xlSheet.Cells(1, 1), _
    xlSheet.Cells(1, objRST.Fields.Count)).Font.Bold = True

    With xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(1, objRST.Fields.Count)).Interior
    .ColorIndex = 15
    .Pattern = xlSolid
    End With

    With xlSheet.Range(xlSheet.Cells(1, 1), _
    xlSheet.Cells(1, objRST.Fields.Count)).Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With

    With xlSheet.Range(xlSheet.Cells(1, 1), _
    xlSheet.Cells(1, objRST.Fields.Count)).Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With

    With xlSheet.Range(xlSheet.Cells(1, 1), _
    xlSheet.Cells(1, objRST.Fields.Count)).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With

    With xlSheet.Range(xlSheet.Cells(1, 1), _
    xlSheet.Cells(1, objRST.Fields.Count)).Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With

    With xlSheet
         xlApp.ActiveWindow.Zoom = 90
    End With

    With xlSheet
        .Range("A2").CopyFromRecordset objRST
        .Name = strSheetName
    End With

    With xlApp
         xlApp.Sheets("Sheet2").Select
         xlApp.ActiveWindow.SelectedSheets.Delete
         xlApp.Sheets("Sheet3").Select
         xlApp.ActiveWindow.SelectedSheets.Delete
    End With

    With xlSheet
        .Cells.EntireColumn.AutoFit
        .Cells.WrapText = False
    End With

    Set objRST = Nothing
    Set xlApp = Nothing
    Set xlBook = Nothing
    Set xlSheet = Nothing
        
End Function

 

[Fattire]

Oh, and I took out that extra recordset in there (rec1), sorry about that.