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>