《从Excel到Access》课程第8课VBA代码

时　间:2018-04-03 11:51:23
作　者:张志   ID：8  城市：上海  QQ：2851379730
摘　要:第8课《输出到Excel（2）》中的VBA代码，供学员参考。
正　文:

     《从Excel到Access数据库》课程是为广大Excel用户了解、学习Access开设的一个实用课程，侧重于数据统计分析。本课程选取的案例是对银行年化贷款收益率分析，在这个案例中，数据记录达60多万条，根据工作需要，定期每月分析1-2次。银行的分析师是一位熟练的Excel用户，他每次制作本报表用EXCEL需要花费1小时左右，改用Access数据库后只需要花90秒。

      >>单击此进入《从Excel到Access数据库》课程

示例代码如下：

 '要引用 Microsoft Excel X.0 Object Library (例如office2010,是14.0版本)
    Dim ExApp As Excel.Application
    Dim Book As Excel.Workbook '工作簿
    Dim ws As Excel.Worksheet '工作表
    Dim xlsPath As String 'Excel文件路径
    Dim rst As DAO.Recordset
    Dim strSQL As String
    Dim i As Integer
    
    xlsPath = CurrentProject.Path + "\贷款收益率.xlt"
    If Dir(xlsPath) = "" Then
        MsgBox "缺少Excel模板文件:" & vbNewLine & xlsPath, vbCritical, "提示"
        Exit Sub
    End If
    Set ExApp = New Excel.Application
    Set Book = ExApp.Workbooks.Open(xlsPath) '激活Excel模板文件
    Set ws = Book.Worksheets("年化贷款收益率") '工作表
    ExApp.Visible = True '显示Excel
    
    strSQL = "select * from tbl年化贷款收益率 order by 顺序号"
    Set rst = CurrentDb.OpenRecordset(strSQL) '用DAO打开记录集
    rst.MoveFirst '移到第一行记录
    i = 3 'Excel表是从第3行写入数据的
    Do Until rst.EOF
        If Not IsNull(rst!条线) And Not IsNull(rst!类型) Then
            '如果条线和类型都为空值，写入条线，换行，再写入类型，换行
            ws.Cells(i, 1) = "  " & rst!条线 '给第3行第1列写入值
            ws.Cells(i + 1, 1) = "    " & rst!类型 '给第4行第1列写入值
            ws.Cells(i + 2, 1) = "      " & rst!产品名称 '给第5行第1列写入值
            ws.Cells(i + 2, 2) = Val(rst!北京分行) '给第5行第2列写入值
            ws.Cells(i + 2, 3) = Val(rst!天津分行) '给第5行第3列写入值
            ws.Cells(i + 2, 4) = Val(rst!上海分行) '给第5行第4列写入值
            ws.Cells(i + 2, 5) = Val(rst!重庆分行)
            ws.Cells(i + 2, 6) = Val(rst!成都分行)
            ws.Cells(i + 2, 7) = Val(rst!杭州分行)
            ws.Cells(i + 2, 8) = Val(rst!宁波分行)
            ws.Cells(i + 2, 9) = Val(rst!温州分行)
            ws.Cells(i + 2, 10) = Val(rst!东莞分行)
            ws.Cells(i + 2, 11) = Val(rst!佛山分行)
            ws.Cells(i + 2, 12) = Val(rst!太原分行)
            ws.Cells(i + 2, 13) = Val(rst!昆明分行)
            ws.Cells(i + 2, 14) = Val(rst!义乌分行)
            i = i + 2
        Else
            If IsNull(rst!条线) And Not IsNull(rst!类型) Then
                '如果条线为空值并且类型不为空值，写入类型并换行
                ws.Cells(i, 1) = "    " & rst!类型
                ws.Cells(i + 1, 1) = "      " & rst!产品名称
                ws.Cells(i + 1, 2) = Val(rst!北京分行)
                ws.Cells(i + 1, 3) = Val(rst!天津分行)
                ws.Cells(i + 1, 4) = Val(rst!上海分行)
                ws.Cells(i + 1, 5) = Val(rst!重庆分行)
                ws.Cells(i + 1, 6) = Val(rst!成都分行)
                ws.Cells(i + 1, 7) = Val(rst!杭州分行)
                ws.Cells(i + 1, 8) = Val(rst!宁波分行)
                ws.Cells(i + 1, 9) = Val(rst!温州分行)
                ws.Cells(i + 1, 10) = Val(rst!东莞分行)
                ws.Cells(i + 1, 11) = Val(rst!佛山分行)
                ws.Cells(i + 1, 12) = Val(rst!太原分行)
                ws.Cells(i + 1, 13) = Val(rst!昆明分行)
                ws.Cells(i + 1, 14) = Val(rst!义乌分行)
                i = i + 1
            Else
                '上面两个条件都不满足，说明是具体产品
                ws.Cells(i, 1) = "      " & rst!产品名称
                ws.Cells(i, 2) = Val(rst!北京分行)
                ws.Cells(i, 3) = Val(rst!天津分行)
                ws.Cells(i, 4) = Val(rst!上海分行)
                ws.Cells(i, 5) = Val(rst!重庆分行)
                ws.Cells(i, 6) = Val(rst!成都分行)
                ws.Cells(i, 7) = Val(rst!杭州分行)
                ws.Cells(i, 8) = Val(rst!宁波分行)
                ws.Cells(i, 9) = Val(rst!温州分行)
                ws.Cells(i, 10) = Val(rst!东莞分行)
                ws.Cells(i, 11) = Val(rst!佛山分行)
                ws.Cells(i, 12) = Val(rst!太原分行)
                ws.Cells(i, 13) = Val(rst!昆明分行)
                ws.Cells(i, 14) = Val(rst!义乌分行)
            End If
        End If
        i = i + 1
        rst.MoveNext
    Loop
    rst.Close
    Set rst = Nothing