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

Hi，大家好呀！

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

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

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

如下图：

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

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

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

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

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

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

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

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

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

来源：兰兰课堂