Public Function ExportToExcel(WorkbookName As String, _
                              Optional WorksheetName As String, _
                              Optional StartRange As String = "A1" _
                              ) As String
    On Error GoTo ErrorHandler

    DoCmd.Hourglass True
   
    Dim strExtensions As String: strExtensions = IIf(Val(Application.Version) <= 11, ".xls", ".xlsx")
    Dim strFileName   As String: strFileName = WorkbookName
    If InStrRev(strFileName, ".") > 0 Then
        Dim strExtName As String: strExtName = Mid$(strFileName, InStrRev(strFileName, "."))
        strFileName = Left$(WorkbookName, Len(WorkbookName) - Len(strExtName))
        If strExtName = ".xls" or strExtName = ".xlsx" Then strExtensions = strExtName
    End If
    With Application.FileDialog(msoFileDialogSaveAs)
        .InitialFileName = strFileName & strExtensions
        If Not .Show Then GoTo ExitHere
        strFileName = .SelectedItems(1)
        If InStrRev(strFileName, ".") > 0 Then
            strExtName = Mid$(strFileName, InStrRev(strFileName, "."))
            strFileName = Left$(strFileName, Len(strFileName) - Len(strExtName))
            If strExtName = ".xls" or strExtName = ".xlsx" Then strExtensions = strExtName
        End If
        strFileName = strFileName & strExtensions
    End With
    If Len(Dir(strFileName)) > 0 Then Kill strFileName   
   
    Dim objApp As Object: Set objApp = CreateObject("Excel.Application")
    objApp.CutCopyMode = xlCopy
    RunCommand acCmdSelectAllRecords
    RunCommand acCmdCopy
    SendKeys "{TAB}", True
'    objApp.Visible = True
    Dim objBook As Object: Set objBook = objApp.Workbooks.Add()
    Do Until objBook.Sheets.Count = 1
        objBook.Sheets(1).Delete                                    '
    Loop
    Dim objSheet As Object: Set objSheet = objBook.Sheets(1)
    objSheet.Range(StartRange).Select
    objSheet.Paste
    EmptyAccessClipboard
    objApp.ActiveWindow.SplitRow = objSheet.Range(StartRange).Row
    objApp.ActiveWindow.FreezePanes = True
    objApp.ActiveWindow.DisplayGridlines = False
   
    If strFileName Like "*.xlsx" And Val(objApp.Version) < 12 Then
        strFileName = Left$(strFileName, Len(strFileName) - 1)
    End If
    If Len(WorksheetName) > 0 Then
        objSheet.Name = WorksheetName
    Else
        strExtName = Mid$(strFileName, InStrRev(strFileName, "\") + 1)
        If InStrRev(strExtName, ".") > 0 Then
            strExtName = Left$(strExtName, InStrRev(strExtName, ".") - 1)
        End If
        objSheet.Name = strExtName
    End If

    objApp.ScreenUpdating = False
    Dim lngRow    As Long: lngRow = objSheet.Range(StartRange).Row + objSheet.UsedRange.Rows.Count - 1
    Dim lngColumn As Long: lngColumn = objSheet.Range(StartRange).Column + objSheet.UsedRange.Columns.Count - 1
    On Error Resume Next
    With objSheet.Range(StartRange, objSheet.Cells(lngRow, lngColumn))
        .Select
        .RowHeight = 13.5
        .ColumnWidth = 100
        .EntireColumn.AutoFit
'        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
       
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
       
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeLeft).Weight = xlThin
        .Borders(xlEdgeLeft).ColorIndex = xlAutomatic
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeTop).Weight = xlThin
        .Borders(xlEdgeTop).ColorIndex = xlAutomatic
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).Weight = xlThin
        .Borders(xlEdgeBottom).ColorIndex = xlAutomatic
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlEdgeRight).Weight = xlThin
        .Borders(xlEdgeRight).ColorIndex = xlAutomatic
       
        .Borders(xlInsideVertical).LineStyle = xlContinuous
        .Borders(xlInsideVertical).Weight = xlThin
        .Borders(xlInsideVertical).ColorIndex = xlAutomatic
       
        .Borders(xlInsideHorizontal).LineStyle = xlContinuous
        .Borders(xlInsideHorizontal).Weight = xlThin
        .Borders(xlInsideHorizontal).ColorIndex = xlAutomatic
'    .Interior.ColorIndex = xlNone
    End With
    On Error GoTo ErrorHandler
'    objSheet.Rows(1).RowHeight = 27
'    objSheet.Range("A1", objSheet.Cells(1, lngColumn)).Interior.Color = 15986395
    objApp.Range(StartRange).Select
    If strFileName Like "*.xls" Then
        If Val(objApp.Version) > 11 Then
            objBook.SaveAs strFileName, xlExcel8
        Else
            objBook.SaveAs strFileName
        End If
    Else
        objBook.SaveAs strFileName, xlOpenXMLWorkbook
    End If
    objApp.Visible = True
   
    ExportToExcel = strFileName
   
ExitHere:
    On Error Resume Next
    DoCmd.Hourglass False
    objApp.ScreenUpdating = True
    Set objApp = Nothing
    Set objBook = Nothing
    Set objSheet = Nothing
    Exit Function
   
ErrorHandler:
    RDPErrorHandler " Function ExportToExcel()"
    Resume ExitHere
End Function

其它相关资料

快速开发平台--导出Excel文件出现#1004 ExportToExcel()类 Worksheet的Paste方法无效的解决方法[Access软件网]
http://www.accessoft.com/article-show.asp?id=9585
2.0.2版本快速开发平台“导出”出错，错误号#1004解决办法[Access软件网]
http://www.accessoft.com/article-show.asp?id=9739