VBA编程自动导出生成Excel表

    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>