根据一个朋友提供的ACCESS转换EXL代码如下：

Private Sub Command4_Click()
Dim sfile As String
Dim s As String
Dim i As Integer
Dim myexcel As New Excel.Application
Dim mybook As New Excel.Workbook
Dim mysheet As New Excel.Worksheet
Set mybook = myexcel.Workbooks.Add '添加一个新的BOOK
Set mysheet = mybook.Worksheets.Add '添加一个新的SHEET
myexcel.Visible = True
myexcel.UserControl = True
' myexcel.Visible = False
For i = 1 To Rst.Fields.Count
mysheet.Cells(1, i).Value = Rst.Fields(i - 1).Name
Next i
mysheet.Cells(2, 1).CopyFromRecordset Rst
mybook.SaveAs (sfile)
' mybook.Close savechanges:=True
' myexcel.Quit
Set mysheet = Nothing
Set mybook = Nothing
Set myexcel = Nothing
MsgBox "保存数据" & sfile & "成功！"
End Sub

执行后，结果打开了一个EXL，但是同时也出现了个提示框：

无法访问文件，请尝试下列方法之一：
确认指定的文件夹存在
。。。

修改完毕，请看：

Private Sub Command4_Click()
appdisk = Trim(App.Path)
If Right(appdisk, 1) <> "\" Then appdisk = appdisk & "\"
Dim lRow As Long
Dim sXLSPath As String

Dim s As String
Dim i As Integer
Dim myexcel As New Excel.Application
Dim mybook As New Excel.Workbook
Dim mysheet As New Excel.Worksheet
Set mybook = myexcel.Workbooks.Add '添加一个新的BOOK
Set mysheet = mybook.Worksheets.Add '添加一个新的SHEET
myexcel.Visible = True
myexcel.UserControl = True
' myexcel.Visible = False
For i = 1 To Rst.Fields.Count
mysheet.Cells(1, i).Value = Rst.Fields(i - 1).Name
Next i
mysheet.Cells(2, 1).CopyFromRecordset Rst
mybook.SaveAs FileName:=appdisk & "01.xls", FileFormat:=xlNormal, Password:="", writerespassword:="", ReadOnlyRecommended:=False, CreateBackup:=False

' mybook.Close savechanges:=True
' myexcel.Quit

Set mysheet = Nothing
Set mybook = Nothing
Set myexcel = Nothing
MsgBox "转换数据成功！"

执行完毕后，虽然达到了满意的结果，但最后关闭时还是出现了：

实时对象：SaveAs.......

的错误！

请帮忙修改下！

谢谢！

mysheet.Cells(2, 1).CopyFromRecordset Rst
mybook.SaveAs (1)

' mybook.Close savechanges:=True
' myexcel.Quit

Set mysheet = Nothing
Set mybook = Nothing

成功了！

哦！举了例子看看！

谢谢！