1 '将一个表或查询产生的记录集写入Excel表中 2 Function ZExcel(模板名, 文件名, 记录集, 起始行, 字段数, Optional 条件 As String) 3 Dim Excel1 As Object ' 定义引用 Microsoft Excel 的变量。 4 Dim dbs As Database 5 Dim rst As Recordset 6 Dim I, I1 As Integer 7 Dim WJ1, WJ2, s As String 8 'On Error GoTo err1 9 Set dbs = CurrentDb 10 If InStr(1, UCase(模板名), ".XLS") > 0 or InStr(1, UCase(模板名), ".XLSX") > 0 Then '有扩展名 11 WJ1 = CurrentProject.Path & "" & 模板名 '模板文件名 （CurrentProject.Path为当前数据库的路径） 12 Else 13 WJ1 = CurrentProject.Path & "" & 模板名 & ".XLS" '模板文件名 （CurrentProject.Path为当前数据库的路径） 14 End If 15 If InStr(1, UCase(文件名), ".XLS") > 0 or InStr(1, UCase(文件名), ".XLSX") > 0 Then '有扩展名 16 WJ2 = CurrentProject.Path & "" & 文件名 '目标文件名 17 Else 18 WJ2 = CurrentProject.Path & "" & 文件名 & ".XLS" '目标文件名 19 End If 20 FileCopy WJ1, WJ2 '拷贝文件（模板文件拷贝成目标文件） 21 Set Excel1 = GetObject(WJ2, "Excel.Sheet") '建立与Excel的连接变量 22 Excel1.Application.Visible = False '不打开Excel程序 23 Excel1.Parent.Windows(1).Visible = True '可见属性为真 24 If Nz(条件) <> "" Then 记录集 = "select * from " & 记录集 & " where " & 条件 25 Set rst = dbs.OpenRecordset(记录集, 2) '设置记录集 26 If Not rst.EOF Then rst.MoveFirst '记录集头部 27 If Not rst.EOF Then rst.MoveNext '记录集下移一条记录 28 If Not rst.EOF Then rst.MoveNext '记录集下移一条记录 29 s = Mid(Str(起始行 + 1), 2) & ":" & Mid(Str(起始行 + 1), 2) 30 While Not rst.EOF '判断记录集是否结束 31 Excel1.Application.Rows(s).Select '选择Excel的行 32 Excel1.Application.Selection.Insert '插入行 33 rst.MoveNext '记录集下移一条记录 34 Wend '循环结束语句 35 If Not rst.EOF Then rst.MoveFirst '记录集头部 36 I1 = 起始行 'Excel的行 37 While Not rst.EOF '判断记录集是否结束 38 For I = 1 To 字段数 '按字段数循环 39 Excel1.Application.Cells(I1, I).Value = rst.Fields(I - 1) '在Excel列中填写数据 40 Next I '循环结束语句 41 rst.MoveNext '记录集下移一条记录 42 I1 = I1 + 1 '行加1 43 Wend '循环结束语句 44 Excel1.Save '保存Excel 45 Excel1.Application.Quit '关闭Excel 46 Set Excel1 = Nothing '清除内存变量 47 Set dbs = Nothing 48 Set rst = Nothing 49 ZExcel = True 50 Exit Function 51 err1: 52 Set Excel1 = Nothing 53 Set dbs = Nothing 54 Set rst = Nothing 55 ZExcel = False 56 End Function
From <http://www.accessoft.com/article-show.asp?id=4064>