【vba源码】导出Excel并添加筛选功能

时间：2024-12-17 14:24:24


Hi，大家好呀！

今天又到了我们一周一更新的时间，如果大家最近看过我的直播，知道我每周一会更新，那今天怎么周二才更新了？当然是因为忙！咦？怎么又感觉我说了一堆废话呢！哈哈哈！想和大家唠唠嗑，拉近拉近距离，但好像更尴尬了！

OK，废话不多话，我来想想今天分享点啥呢？

最近一直和导入导出杠上了，所以我们还是来讲讲导出功能。我们在导出Excel数据时，想着导出后可以在Excel做一些数据分析的操作，但每次导出后还要手工选择第一列，添加筛选功能，虽说这个操作花不了太多时间，但每次这么操作一次很是反感，特别是一天要导出很多次的情况下，那能不能在导出时直接添加上筛选呢？

如下图：

【vba源码】导出Excel并添加筛选功能_excel

要实现这个功能，超简单，最关键的部分，只要一行代码：

objBook.Sheets("sheet1").Rows("1:1").AutoFilter

关键的代码都告诉你了，那剩下的应该都会操作了吧！让我们来看看吧！

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

第一步还是一样，我们准备一张要导出的表/查询，那我们还是用之前的那张产品表！

【vba源码】导出Excel并添加筛选功能_access_02

2、添加代码

有了要导出的数据之后，我们就可以来添加一下代码了，我们先创建一个窗体，在窗体上放一个导出按钮。

【vba源码】导出Excel并添加筛选功能_筛选_03

接着，我们添加一下代码：

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



    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

    

    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

        .SavePassword = False

        .SaveData = True

        .AdjustColumnWidth = True

        .RefreshPeriod = 0

        .PreserveColumnInfo = True

        .Refresh BackgroundQuery:=False

    End With

    objExcelQuery.Refresh

    rst.Close

    

    objBook.Sheets("sheet1").Rows("1:1").AutoFilter

    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

3、运行测试

最后，就是运行测试了，导出的Excel就是自动添加上筛选功能，如下图：

【vba源码】导出Excel并添加筛选功能_筛选_04

好了，大家快去试一下吧！

相关文章