【vba源码】导出Excel并添加合计行-CFANZ编程社区

hi，大家好呀！

上周给大家分享了一个导入excel批注的功能，大家的反馈都挺热烈的，关于excel的导入与导出功能，我们都讲过不少，但导出功能我们很少讲合计行，那怎么该怎么做呢？今天我们就来看看吧！另外，视频教程在更新中，大家莫急，还有，大家记得在周四或者周五的下午来看我直播，和我唠嗑，一起来学习Access！

01、准备要导出的表/查询

在导出前，我们先要准备一个表，因为导出时，我们需要做合计，所以，准备的表或者查询必须要有数量字段。

比如我们有一张商品表，字段为产品代码、产品名称、产品类别、数量、金额等。表名称我们保存为T_Product，如下图：

【vba源码】导出Excel并添加合计行_windows

02、添加导出代码

接着，我们就需要来添加代码了，在添加代码前，我们需要先创建一下窗体，在窗体上放一个导出按钮，如下图：

【vba源码】导出Excel并添加合计行_java_02

在按钮的单击事件里添加如下代码：

Private Sub btnExport_Click()

On Error GoTo Err_ExportToExcel

    Dim strName As String

    Dim objExcel As Object

    Dim objBook As Object

    Dim objSheet As Object

    Dim rst As Object

    Dim objExcelQuery As Object

    Dim intI As Long

    strName = "产品名称.xlsx"

    '使用文件对话框取得另存为的文件名

    With Application.FileDialog(2)    'msoFileDialogSaveAs

        .InitialFileName = strName

        If .Show Then

            strName = .SelectedItems(1)

            If Not strName Like "*.xlsx" Then strName = strName & ".xlsx"

        Else

            strName = ""

        End If

    End With

    If strName = "" Then Exit Sub

    DoCmd.Hourglass True

    intI = DCount("*", "T_Product")

    Set objExcel = CreateObject("Excel.Application")

    Set objBook = objExcel.Workbooks().Add()

    Set objSheet = objBook.Worksheets("sheet1")

    

    Set rst = CurrentDb.OpenRecordset("T_Product")

    Set objExcelQuery = objSheet.QueryTables.Add(rst, objSheet.Range("A1"))

    With objExcelQuery

        .FieldNames = True

        .RowNumbers = False

        .FillAdjacentFormulas = False

        .PreserveFormatting = True

        .RefreshOnFileOpen = False

        .BackgroundQuery = True

        ' .RefreshStyle = xlInsertDeleteCells

        .SavePassword = False

        .SaveData = True

        .AdjustColumnWidth = True

        .RefreshPeriod = 0

        .PreserveColumnInfo = True

        .Refresh BackgroundQuery:=False

    End With

    objExcelQuery.Refresh

    rst.Close

    '加2，是因为需要算上第一标题与本身的一行

    objSheet.Range("A" & intI + 2) = "合计"

    objSheet.Range("A" & intI + 2).Font.Bold = True

    objSheet.Range("E" & intI + 2) = "= Sum(E2:E" & intI + 1 & ")"

    objSheet.Range("E" & intI + 2).Font.Bold = True

    objSheet.Range("F" & intI + 2) = "= Sum(F2:F" & intI + 1 & ")"

    objSheet.Range("F" & intI + 2).Font.Bold = True

    objBook.Worksheets("sheet1").SaveAs strName



    If MsgBox("数据已导出，是否打开并查看？", vbQuestion + vbYesNo) = vbYes Then

        objExcel.Visible = True

    Else

        objBook.Saved = True

        objExcel.Quit

    End If



Exit_ExportToExcel:

    Set objExcel = Nothing

    Set objBook = Nothing

    Set objSheet = Nothing

    Set rst = Nothing

    DoCmd.Hourglass False

    Exit Sub

    

Err_ExportToExcel:

    If Err = 70 Then

        MsgBox "无法删除文件 '" & strName & "'，可能该文件已被打开或没有权限。", vbCritical

    Else

        MsgBox Err.Source & " #" & Err & vbCrLf & vbCrLf & Err.Description, vbCritical

    End If

    Resume Exit_ExportToExcel

End Sub